← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:09 2010

File /usr/local/lib/perl/5.10.0/Moose/Meta/Role/Application/RoleSummation.pm
Statements Executed 23
Total Time 0.0019911 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMoose::Meta::Role::Application::RoleSummation::::BEGINMoose::Meta::Role::Application::RoleSummation::BEGIN
0000s0sMoose::Meta::Role::Application::RoleSummation::::__ANON__[:19]Moose::Meta::Role::Application::RoleSummation::__ANON__[:19]
0000s0sMoose::Meta::Role::Application::RoleSummation::::apply_attributesMoose::Meta::Role::Application::RoleSummation::apply_attributes
0000s0sMoose::Meta::Role::Application::RoleSummation::::apply_method_modifiersMoose::Meta::Role::Application::RoleSummation::apply_method_modifiers
0000s0sMoose::Meta::Role::Application::RoleSummation::::apply_methodsMoose::Meta::Role::Application::RoleSummation::apply_methods
0000s0sMoose::Meta::Role::Application::RoleSummation::::apply_override_method_modifiersMoose::Meta::Role::Application::RoleSummation::apply_override_method_modifiers
0000s0sMoose::Meta::Role::Application::RoleSummation::::check_required_attributesMoose::Meta::Role::Application::RoleSummation::check_required_attributes
0000s0sMoose::Meta::Role::Application::RoleSummation::::check_required_methodsMoose::Meta::Role::Application::RoleSummation::check_required_methods
0000s0sMoose::Meta::Role::Application::RoleSummation::::check_role_exclusionsMoose::Meta::Role::Application::RoleSummation::check_role_exclusions
0000s0sMoose::Meta::Role::Application::RoleSummation::::get_exclusions_for_roleMoose::Meta::Role::Application::RoleSummation::get_exclusions_for_role
0000s0sMoose::Meta::Role::Application::RoleSummation::::get_method_aliases_for_roleMoose::Meta::Role::Application::RoleSummation::get_method_aliases_for_role
0000s0sMoose::Meta::Role::Application::RoleSummation::::is_aliased_methodMoose::Meta::Role::Application::RoleSummation::is_aliased_method
0000s0sMoose::Meta::Role::Application::RoleSummation::::is_method_aliasedMoose::Meta::Role::Application::RoleSummation::is_method_aliased
0000s0sMoose::Meta::Role::Application::RoleSummation::::is_method_excludedMoose::Meta::Role::Application::RoleSummation::is_method_excluded
LineStmts.Exclusive
Time
Avg.Code
1package Moose::Meta::Role::Application::RoleSummation;
2
3325µs8µsuse strict;
# spent 8µs making 1 call to strict::import
4334µs11µsuse warnings;
# spent 22µs making 1 call to warnings::import
5354µs18µsuse metaclass;
# spent 830µs making 1 call to metaclass::import
6
7332µs11µsuse Scalar::Util 'blessed';
# spent 44µs making 1 call to Exporter::import
8
9373µs24µsuse Moose::Meta::Role::Composite;
# spent 4µs making 1 call to import
10
111900ns900nsour $VERSION = '1.15';
12125µs25µs$VERSION = eval $VERSION;
131600ns600nsour $AUTHORITY = 'cpan:STEVAN';
14
1531.72ms573µsuse base 'Moose::Meta::Role::Application';
# spent 75µs making 1 call to base::import
16
17__PACKAGE__->meta->add_attribute('role_params' => (
18 reader => 'role_params',
19 default => sub { {} }
20119µs19µs));
21
22sub get_exclusions_for_role {
23 my ($self, $role) = @_;
24 $role = $role->name if blessed $role;
25 my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ?
26 '-excludes' : 'excludes';
27 if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) {
28 if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') {
29 return $self->role_params->{$role}->{$excludes_key};
30 }
31 return [ $self->role_params->{$role}->{$excludes_key} ];
32 }
33 return [];
34}
35
36sub get_method_aliases_for_role {
37 my ($self, $role) = @_;
38 $role = $role->name if blessed $role;
39 my $alias_key = exists $self->role_params->{$role}->{'-alias'} ?
40 '-alias' : 'alias';
41 if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) {
42 return $self->role_params->{$role}->{$alias_key};
43 }
44 return {};
45}
46
47sub is_method_excluded {
48 my ($self, $role, $method_name) = @_;
49 foreach ($self->get_exclusions_for_role($role->name)) {
50 return 1 if $_ eq $method_name;
51 }
52 return 0;
53}
54
55sub is_method_aliased {
56 my ($self, $role, $method_name) = @_;
57 exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
58}
59
60sub is_aliased_method {
61 my ($self, $role, $method_name) = @_;
62 my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
63 exists $aliased_names{$method_name} ? 1 : 0;
64}
65
66sub check_role_exclusions {
67 my ($self, $c) = @_;
68
69 my %excluded_roles;
70 for my $role (@{ $c->get_roles }) {
71 my $name = $role->name;
72
73 for my $excluded ($role->get_excluded_roles_list) {
74 push @{ $excluded_roles{$excluded} }, $name;
75 }
76 }
77
78 foreach my $role (@{$c->get_roles}) {
79 foreach my $excluded (keys %excluded_roles) {
80 next unless $role->does_role($excluded);
81
82 my @excluding = @{ $excluded_roles{$excluded} };
83
84 require Moose;
85 Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
86 }
87 }
88
89 $c->add_excluded_roles(keys %excluded_roles);
90}
91
92sub check_required_methods {
93 my ($self, $c) = @_;
94
95 my %all_required_methods =
96 map { $_->name => $_ }
97 map { $_->get_required_method_list }
98 @{$c->get_roles};
99
100 foreach my $role (@{$c->get_roles}) {
101 foreach my $required (keys %all_required_methods) {
102
103 delete $all_required_methods{$required}
104 if $role->has_method($required)
105 || $self->is_aliased_method($role, $required);
106 }
107 }
108
109 $c->add_required_methods(values %all_required_methods);
110}
111
112sub check_required_attributes {
113
114}
115
116sub apply_attributes {
117 my ($self, $c) = @_;
118
119 my @all_attributes;
120
121 for my $role ( @{ $c->get_roles } ) {
122 push @all_attributes,
123 map { $role->get_attribute($_) } $role->get_attribute_list;
124 }
125
126 my %seen;
127 foreach my $attr (@all_attributes) {
128 my $name = $attr->name;
129
130 if ( exists $seen{$name} ) {
131 next if $seen{$name}->is_same_as($attr);
132
133 my $role1 = $seen{$name}->associated_role->name;
134 my $role2 = $attr->associated_role->name;
135
136 require Moose;
137 Moose->throw_error(
138 "We have encountered an attribute conflict with '$name' "
139 . "during role composition. "
140 . " This attribute is defined in both $role1 and $role2."
141 . " This is fatal error and cannot be disambiguated." );
142 }
143
144 $seen{$name} = $attr;
145 }
146
147 foreach my $attr (@all_attributes) {
148 $c->add_attribute( $attr->clone );
149 }
150}
151
152sub apply_methods {
153 my ($self, $c) = @_;
154
155 my @all_methods = map {
156 my $role = $_;
157 my $aliases = $self->get_method_aliases_for_role($role);
158 my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
159 (
160 (map {
161 exists $excludes{$_} ? () :
162 +{
163 role => $role,
164 name => $_,
165 method => $role->get_method($_),
166 }
167 } map { $_->name }
168 grep { !$_->isa('Class::MOP::Method::Meta') }
169 $role->_get_local_methods),
170 (map {
171 +{
172 role => $role,
173 name => $aliases->{$_},
174 method => $role->get_method($_),
175 }
176 } keys %$aliases)
177 );
178 } @{$c->get_roles};
179
180 my (%seen, %method_map);
181 foreach my $method (@all_methods) {
182 my $seen = $seen{$method->{name}};
183
184 if ($seen) {
185 if ($seen->{method}->body != $method->{method}->body) {
186 $c->add_conflicting_method(
187 name => $method->{name},
188 roles => [$method->{role}->name, $seen->{role}->name],
189 );
190
191 delete $method_map{$method->{name}};
192 next;
193 }
194 }
195
196 $seen{$method->{name}} = $method;
197 $method_map{$method->{name}} = $method->{method};
198 }
199
200 $c->add_method($_ => $method_map{$_}) for keys %method_map;
201}
202
203sub apply_override_method_modifiers {
204 my ($self, $c) = @_;
205
206 my @all_overrides = map {
207 my $role = $_;
208 map {
209 +{
210 name => $_,
211 method => $role->get_override_method_modifier($_),
212 }
213 } $role->get_method_modifier_list('override');
214 } @{$c->get_roles};
215
216 my %seen;
217 foreach my $override (@all_overrides) {
218 if ( $c->has_method($override->{name}) ){
219 require Moose;
220 Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " .
221 "during composition (A local method of the same name as been found). This " .
222 "is fatal error." )
223 }
224 if (exists $seen{$override->{name}}) {
225 if ( $seen{$override->{name}} != $override->{method} ) {
226 require Moose;
227 Moose->throw_error( "We have encountered an 'override' method conflict during " .
228 "composition (Two 'override' methods of the same name encountered). " .
229 "This is fatal error.")
230 }
231 }
232 $seen{$override->{name}} = $override->{method};
233 }
234
235 $c->add_override_method_modifier(
236 $_->{name}, $_->{method}
237 ) for @all_overrides;
238
239}
240
241sub apply_method_modifiers {
242 my ($self, $modifier_type, $c) = @_;
243 my $add = "add_${modifier_type}_method_modifier";
244 my $get = "get_${modifier_type}_method_modifiers";
245 foreach my $role (@{$c->get_roles}) {
246 foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
247 $c->$add(
248 $method_name,
249 $_
250 ) foreach $role->$get($method_name);
251 }
252 }
253}
254
25519µs9µs1;
256
257__END__
258
259=pod
260
261=head1 NAME
262
263Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
264
265=head1 DESCRIPTION
266
267Summation composes two traits, forming the union of non-conflicting
268bindings and 'disabling' the conflicting bindings
269
270=head2 METHODS
271
272=over 4
273
274=item B<new>
275
276=item B<meta>
277
278=item B<role_params>
279
280=item B<get_exclusions_for_role>
281
282=item B<get_method_aliases_for_role>
283
284=item B<is_aliased_method>
285
286=item B<is_method_aliased>
287
288=item B<is_method_excluded>
289
290=item B<apply>
291
292=item B<check_role_exclusions>
293
294=item B<check_required_methods>
295
296=item B<check_required_attributes>
297
298=item B<apply_attributes>
299
300=item B<apply_methods>
301
302=item B<apply_method_modifiers>
303
304=item B<apply_override_method_modifiers>
305
306=back
307
308=head1 BUGS
309
310See L<Moose/BUGS> for details on reporting bugs.
311
312=head1 AUTHOR
313
314Stevan Little E<lt>stevan@iinteractive.comE<gt>
315
316=head1 COPYRIGHT AND LICENSE
317
318Copyright 2006-2010 by Infinity Interactive, Inc.
319
320L<http://www.iinteractive.com>
321
322This library is free software; you can redistribute it and/or modify
323it under the same terms as Perl itself.
324
325=cut
326