← 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:08 2010

File /usr/local/lib/perl/5.10.0/Moose/Util/MetaRole.pm
Statements Executed 22
Total Time 0.0011041 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMoose::Util::MetaRole::::BEGINMoose::Util::MetaRole::BEGIN
0000s0sMoose::Util::MetaRole::::__ANON__[:116]Moose::Util::MetaRole::__ANON__[:116]
0000s0sMoose::Util::MetaRole::::__ANON__[:160]Moose::Util::MetaRole::__ANON__[:160]
0000s0sMoose::Util::MetaRole::::_fixup_old_style_argsMoose::Util::MetaRole::_fixup_old_style_args
0000s0sMoose::Util::MetaRole::::_make_new_classMoose::Util::MetaRole::_make_new_class
0000s0sMoose::Util::MetaRole::::_make_new_metaclassMoose::Util::MetaRole::_make_new_metaclass
0000s0sMoose::Util::MetaRole::::apply_base_class_rolesMoose::Util::MetaRole::apply_base_class_roles
0000s0sMoose::Util::MetaRole::::apply_metaclass_rolesMoose::Util::MetaRole::apply_metaclass_roles
0000s0sMoose::Util::MetaRole::::apply_metarolesMoose::Util::MetaRole::apply_metaroles
LineStmts.Exclusive
Time
Avg.Code
1package Moose::Util::MetaRole;
2
3322µs7µsuse strict;
# spent 7µs making 1 call to strict::import
4331µs10µsuse warnings;
# spent 25µs making 1 call to warnings::import
5362µs21µsuse Scalar::Util 'blessed';
# spent 40µs making 1 call to Exporter::import
6
71900ns900nsour $VERSION = '1.15';
8122µs22µs$VERSION = eval $VERSION;
91600ns600nsour $AUTHORITY = 'cpan:STEVAN';
10
11331µs10µsuse List::MoreUtils qw( all );
# spent 43µs making 1 call to Exporter::import
12327µs9µsuse List::Util qw( first );
# spent 44µs making 1 call to Exporter::import
133902µs301µsuse Moose::Deprecated;
14
15sub apply_metaclass_roles {
16 Moose::Deprecated::deprecated(
17 feature => 'pre-0.94 MetaRole API',
18 message =>
19 'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
20 );
21
22 goto &apply_metaroles;
23}
24
25sub apply_metaroles {
26 my %args = @_;
27
28 _fixup_old_style_args(\%args);
29
30 my $for
31 = blessed $args{for}
32 ? $args{for}
33 : Class::MOP::class_of( $args{for} );
34
35 if ( $for->isa('Moose::Meta::Role') ) {
36 return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
37 }
38 else {
39 return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
40 }
41}
42
43sub _fixup_old_style_args {
44 my $args = shift;
45
46 return if $args->{class_metaroles} || $args->{role_metaroles};
47
48 Moose::Deprecated::deprecated(
49 feature => 'pre-0.94 MetaRole API',
50 message =>
51 'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
52 );
53
54 $args->{for} = delete $args->{for_class}
55 if exists $args->{for_class};
56
57 my @old_keys = qw(
58 attribute_metaclass_roles
59 method_metaclass_roles
60 wrapped_method_metaclass_roles
61 instance_metaclass_roles
62 constructor_class_roles
63 destructor_class_roles
64 error_class_roles
65
66 application_to_class_class_roles
67 application_to_role_class_roles
68 application_to_instance_class_roles
69 application_role_summation_class_roles
70 );
71
72 my $for
73 = blessed $args->{for}
74 ? $args->{for}
75 : Class::MOP::class_of( $args->{for} );
76
77 my $top_key;
78 if ( $for->isa('Moose::Meta::Class') ) {
79 $top_key = 'class_metaroles';
80
81 $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
82 if exists $args->{metaclass_roles};
83 }
84 else {
85 $top_key = 'role_metaroles';
86
87 $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
88 if exists $args->{metaclass_roles};
89 }
90
91 for my $old_key (@old_keys) {
92 my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
93
94 $args->{$top_key}{$new_key} = delete $args->{$old_key}
95 if exists $args->{$old_key};
96 }
97
98 return;
99}
100
101sub _make_new_metaclass {
102 my $for = shift;
103 my $roles = shift;
104 my $primary = shift;
105
106 return $for unless keys %{$roles};
107
108 my $new_metaclass
109 = exists $roles->{$primary}
110 ? _make_new_class( ref $for, $roles->{$primary} )
111 : blessed $for;
112
113 my %classes;
114
115 for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
116 my $attr = first {$_}
117 map { $for->meta->find_attribute_by_name($_) } (
118 $key . '_metaclass',
119 $key . '_class'
120 );
121
122 my $reader = $attr->get_read_method;
123
124 $classes{ $attr->init_arg }
125 = _make_new_class( $for->$reader(), $roles->{$key} );
126 }
127
128 my $new_meta = $new_metaclass->reinitialize( $for, %classes );
129
130 return $new_meta;
131}
132
133sub apply_base_class_roles {
134 my %args = @_;
135
136 my $for = $args{for} || $args{for_class};
137
138 my $meta = Class::MOP::class_of($for);
139
140 my $new_base = _make_new_class(
141 $for,
142 $args{roles},
143 [ $meta->superclasses() ],
144 );
145
146 $meta->superclasses($new_base)
147 if $new_base ne $meta->name();
148}
149
150sub _make_new_class {
151 my $existing_class = shift;
152 my $roles = shift;
153 my $superclasses = shift || [$existing_class];
154
155 return $existing_class unless $roles;
156
157 my $meta = Class::MOP::Class->initialize($existing_class);
158
159 return $existing_class
160 if $meta->can('does_role') && all { $meta->does_role($_) }
161 grep { !ref $_ } @{$roles};
162
163 return Moose::Meta::Class->create_anon_class(
164 superclasses => $superclasses,
165 roles => $roles,
166 cache => 1,
167 )->name();
168}
169
17014µs4µs1;
171
172__END__
173
174=head1 NAME
175
176Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
177
178=head1 SYNOPSIS
179
180 package MyApp::Moose;
181
182 use Moose ();
183 use Moose::Exporter;
184 use Moose::Util::MetaRole;
185
186 use MyApp::Role::Meta::Class;
187 use MyApp::Role::Meta::Method::Constructor;
188 use MyApp::Role::Object;
189
190 Moose::Exporter->setup_import_methods( also => 'Moose' );
191
192 sub init_meta {
193 shift;
194 my %args = @_;
195
196 Moose->init_meta(%args);
197
198 Moose::Util::MetaRole::apply_metaroles(
199 for => $args{for_class},
200 class_metaroles => {
201 class => => ['MyApp::Role::Meta::Class'],
202 constructor => ['MyApp::Role::Meta::Method::Constructor'],
203 },
204 );
205
206 Moose::Util::MetaRole::apply_base_class_roles(
207 for => $args{for_class},
208 roles => ['MyApp::Role::Object'],
209 );
210
211 return $args{for_class}->meta();
212 }
213
214=head1 DESCRIPTION
215
216This utility module is designed to help authors of Moose extensions
217write extensions that are able to cooperate with other Moose
218extensions. To do this, you must write your extensions as roles, which
219can then be dynamically applied to the caller's metaclasses.
220
221This module makes sure to preserve any existing superclasses and roles
222already set for the meta objects, which means that any number of
223extensions can apply roles in any order.
224
225=head1 USAGE
226
227The easiest way to use this module is through L<Moose::Exporter>, which can
228generate the appropriate C<init_meta> method for you, and make sure it is
229called when imported.
230
231=head1 FUNCTIONS
232
233This module provides two functions.
234
235=head2 apply_metaroles( ... )
236
237This function will apply roles to one or more metaclasses for the specified
238class. It will return a new metaclass object for the class or role passed in
239the "for" parameter.
240
241It accepts the following parameters:
242
243=over 4
244
245=item * for => $name
246
247This specifies the class or for which to alter the meta classes. This can be a
248package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
249L<Moose::Meta::Role>).
250
251=item * class_metaroles => \%roles
252
253This is a hash reference specifying which metaroles will be applied to the
254class metaclass and its contained metaclasses and helper classes.
255
256Each key should in turn point to an array reference of role names.
257
258It accepts the following keys:
259
260=over 8
261
262=item class
263
264=item attribute
265
266=item method
267
268=item wrapped_method
269
270=item instance
271
272=item constructor
273
274=item destructor
275
276=item error
277
278=back
279
280=item * role_metaroles => \%roles
281
282This is a hash reference specifying which metaroles will be applied to the
283role metaclass and its contained metaclasses and helper classes.
284
285It accepts the following keys:
286
287=over 8
288
289=item role
290
291=item attribute
292
293=item method
294
295=item required_method
296
297=item conflicting_method
298
299=item application_to_class
300
301=item application_to_role
302
303=item application_to_instance
304
305=item application_role_summation
306
307=back
308
309=back
310
311=head2 apply_base_class_roles( for => $class, roles => \@roles )
312
313This function will apply the specified roles to the object's base class.
314
315=head1 BUGS
316
317See L<Moose/BUGS> for details on reporting bugs.
318
319=head1 AUTHOR
320
321Dave Rolsky E<lt>autarch@urth.orgE<gt>
322
323=head1 COPYRIGHT AND LICENSE
324
325Copyright 2009 by Infinity Interactive, Inc.
326
327L<http://www.iinteractive.com>
328
329This library is free software; you can redistribute it and/or modify
330it under the same terms as Perl itself.
331
332=cut