File Coverage

blib/lib/MooseX/MethodAttributes/Role/Meta/Class.pm
Criterion Covered Total %
statement 38 38 100.0
branch 7 8 87.5
condition 2 3 66.6
subroutine 6 6 100.0
pod 3 3 100.0
total 56 58 96.5


line stmt bran cond sub pod time code
1             package MooseX::MethodAttributes::Role::Meta::Class;
2             # ABSTRACT: metaclass role for storing code attributes
3              
4             our $VERSION = '0.31';
5              
6 19     19   60550 use Moose::Role;
  19         67  
  19         156  
7 19     19   93111 use Moose::Util qw/find_meta does_role/;
  19         44  
  19         133  
8              
9 19     19   4967 use namespace::autoclean;
  19         38  
  19         238  
10              
11             with qw/
12             MooseX::MethodAttributes::Role::Meta::Map
13             /;
14              
15             #pod =method get_method_with_attributes_list
16             #pod
17             #pod Gets the list of meta methods for local methods of this class that have
18             #pod attributes in the order they have been registered.
19             #pod
20             #pod =cut
21              
22             sub get_method_with_attributes_list {
23 24     24 1 98 my ($self) = @_;
24 24         135 my @methods = map { $self->get_method($_) } $self->get_method_list;
  97         7335  
25 24         427 my %order;
26              
27             {
28 24         36 my $i = 0;
  24         39  
29 24         30 $order{$_} = $i++ for @{ $self->_method_attribute_list };
  24         1131  
30             }
31              
32             return map {
33 47         139 $_->[1]
34             } sort {
35 35         96 $order{ $a->[0] } <=> $order{ $b->[0] }
36             } map {
37 57         188 my $addr = 0 + $_->_get_attributed_coderef;
38 57 100       2395 exists $self->_method_attribute_map->{$addr}
39             ? [$addr, $_]
40             : ()
41             } grep {
42 24         53 $_->can('_get_attributed_coderef')
  97         445  
43             } @methods;
44             }
45              
46             #pod =method get_all_methods_with_attributes
47             #pod
48             #pod Gets the list of meta methods of local and inherited methods of this class,
49             #pod that have attributes. Base class methods come before subclass methods. Methods
50             #pod of one class have the order they have been declared in.
51             #pod
52             #pod =cut
53              
54             sub get_all_methods_with_attributes {
55 11     11 1 14560 my ($self) = @_;
56 11         22 my %seen;
57              
58             return reverse grep {
59 39         207 !$seen{ $_->name }++
60             } reverse map {
61 11         72 my $meth;
  42         186  
62 42         123 my $meta = find_meta($_);
63 42 100 66     730 ($meta && ($meth = $meta->can('get_method_with_attributes_list')))
64             ? $meta->$meth
65             : ()
66             } reverse $self->linearized_isa;
67             }
68              
69             #pod =method get_nearest_methods_with_attributes
70             #pod
71             #pod The same as get_all_methods_with_attributes, except that methods from parent classes
72             #pod are not included if there is an attribute-less method in a child class.
73             #pod
74             #pod For example, given:
75             #pod
76             #pod package BaseClass;
77             #pod
78             #pod sub foo : Attr {}
79             #pod
80             #pod sub bar : Attr {}
81             #pod
82             #pod package SubClass;
83             #pod use base qw/BaseClass/;
84             #pod
85             #pod sub foo {}
86             #pod
87             #pod after bar => sub {}
88             #pod
89             #pod C<< SubClass->meta->get_all_methods_with_attributes >> will return
90             #pod C<< BaseClass->meta->get_method('foo') >> for the above example, but
91             #pod this method will not, and will return the wrapped bar method, whereas
92             #pod C<< get_all_methods_with_attributes >> will return the original method.
93             #pod
94             #pod =cut
95              
96             sub get_nearest_methods_with_attributes {
97 3     3 1 2029 my ($self) = @_;
98             my @list = map {
99 3         17 my $m = $self->find_method_by_name($_->name);
  8         50  
100 8         381 my $meth = $m->can('attributes');
101 8 50       113 my $attrs = $meth ? $m->$meth() : [];
102 8 100       12 scalar @{ $attrs } ? ( $m ) : ( );
  8         31  
103             } $self->get_all_methods_with_attributes;
104 3         15 return @list;
105             }
106              
107             foreach my $type (qw/after before around/) {
108             around "add_${type}_method_modifier" => sub {
109             my $orig = shift;
110             my $meta = shift;
111             my ($method_name) = @_;
112              
113             my $code = $meta->$orig(@_);
114             my $method = $meta->get_method($method_name);
115             if (
116             does_role($method->get_original_method, 'MooseX::MethodAttributes::Role::Meta::Method')
117             || does_role($method->get_original_method, 'MooseX::MethodAttributes::Role::Meta::Method::Wrapped')
118             ) {
119             MooseX::MethodAttributes::Role::Meta::Method::Wrapped->meta->apply($method);
120             }
121             return $code;
122             }
123             }
124              
125             1;
126              
127             __END__
128              
129             =pod
130              
131             =encoding UTF-8
132              
133             =head1 NAME
134              
135             MooseX::MethodAttributes::Role::Meta::Class - metaclass role for storing code attributes
136              
137             =head1 VERSION
138              
139             version 0.31
140              
141             =head1 METHODS
142              
143             =head2 get_method_with_attributes_list
144              
145             Gets the list of meta methods for local methods of this class that have
146             attributes in the order they have been registered.
147              
148             =head2 get_all_methods_with_attributes
149              
150             Gets the list of meta methods of local and inherited methods of this class,
151             that have attributes. Base class methods come before subclass methods. Methods
152             of one class have the order they have been declared in.
153              
154             =head2 get_nearest_methods_with_attributes
155              
156             The same as get_all_methods_with_attributes, except that methods from parent classes
157             are not included if there is an attribute-less method in a child class.
158              
159             For example, given:
160              
161             package BaseClass;
162              
163             sub foo : Attr {}
164              
165             sub bar : Attr {}
166              
167             package SubClass;
168             use base qw/BaseClass/;
169              
170             sub foo {}
171              
172             after bar => sub {}
173              
174             C<< SubClass->meta->get_all_methods_with_attributes >> will return
175             C<< BaseClass->meta->get_method('foo') >> for the above example, but
176             this method will not, and will return the wrapped bar method, whereas
177             C<< get_all_methods_with_attributes >> will return the original method.
178              
179             =head1 SUPPORT
180              
181             Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-MethodAttributes>
182             (or L<bug-MooseX-MethodAttributes@rt.cpan.org|mailto:bug-MooseX-MethodAttributes@rt.cpan.org>).
183              
184             There is also a mailing list available for users of this distribution, at
185             L<http://lists.perl.org/list/moose.html>.
186              
187             There is also an irc channel available for users of this distribution, at
188             irc://irc.perl.org/#moose.
189              
190             =head1 AUTHORS
191              
192             =over 4
193              
194             =item *
195              
196             Florian Ragwitz <rafl@debian.org>
197              
198             =item *
199              
200             Tomas Doran <bobtfish@bobtfish.net>
201              
202             =back
203              
204             =head1 COPYRIGHT AND LICENCE
205              
206             This software is copyright (c) 2009 by Florian Ragwitz.
207              
208             This is free software; you can redistribute it and/or modify it under
209             the same terms as the Perl 5 programming language system itself.
210              
211             =cut