File | /usr/local/lib/perl/5.10.0/Moose/Util/MetaRole.pm |
Statements Executed | 22 |
Total Time | 0.0011041 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | __ANON__[:116] | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | __ANON__[:160] | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | _fixup_old_style_args | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | _make_new_class | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | _make_new_metaclass | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | apply_base_class_roles | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | apply_metaclass_roles | Moose::Util::MetaRole::
0 | 0 | 0 | 0s | 0s | apply_metaroles | Moose::Util::MetaRole::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package Moose::Util::MetaRole; | |||
2 | ||||
3 | 3 | 22µs | 7µs | use strict; # spent 7µs making 1 call to strict::import |
4 | 3 | 31µs | 10µs | use warnings; # spent 25µs making 1 call to warnings::import |
5 | 3 | 62µs | 21µs | use Scalar::Util 'blessed'; # spent 40µs making 1 call to Exporter::import |
6 | ||||
7 | 1 | 900ns | 900ns | our $VERSION = '1.15'; |
8 | 1 | 22µs | 22µs | $VERSION = eval $VERSION; |
9 | 1 | 600ns | 600ns | our $AUTHORITY = 'cpan:STEVAN'; |
10 | ||||
11 | 3 | 31µs | 10µs | use List::MoreUtils qw( all ); # spent 43µs making 1 call to Exporter::import |
12 | 3 | 27µs | 9µs | use List::Util qw( first ); # spent 44µs making 1 call to Exporter::import |
13 | 3 | 902µs | 301µs | use Moose::Deprecated; # spent 17µs making 1 call to Package::DeprecationManager::__ANON__[/usr/local/share/perl/5.10.0/Package/DeprecationManager.pm:61] |
14 | ||||
15 | sub 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 | ||||
25 | sub 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 | ||||
43 | sub _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 | ||||
101 | sub _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 | ||||
133 | sub 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 | ||||
150 | sub _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 | ||||
170 | 1 | 4µs | 4µs | 1; |
171 | ||||
172 | __END__ | |||
173 | ||||
174 | =head1 NAME | |||
175 | ||||
176 | Moose::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 | ||||
216 | This utility module is designed to help authors of Moose extensions | |||
217 | write extensions that are able to cooperate with other Moose | |||
218 | extensions. To do this, you must write your extensions as roles, which | |||
219 | can then be dynamically applied to the caller's metaclasses. | |||
220 | ||||
221 | This module makes sure to preserve any existing superclasses and roles | |||
222 | already set for the meta objects, which means that any number of | |||
223 | extensions can apply roles in any order. | |||
224 | ||||
225 | =head1 USAGE | |||
226 | ||||
227 | The easiest way to use this module is through L<Moose::Exporter>, which can | |||
228 | generate the appropriate C<init_meta> method for you, and make sure it is | |||
229 | called when imported. | |||
230 | ||||
231 | =head1 FUNCTIONS | |||
232 | ||||
233 | This module provides two functions. | |||
234 | ||||
235 | =head2 apply_metaroles( ... ) | |||
236 | ||||
237 | This function will apply roles to one or more metaclasses for the specified | |||
238 | class. It will return a new metaclass object for the class or role passed in | |||
239 | the "for" parameter. | |||
240 | ||||
241 | It accepts the following parameters: | |||
242 | ||||
243 | =over 4 | |||
244 | ||||
245 | =item * for => $name | |||
246 | ||||
247 | This specifies the class or for which to alter the meta classes. This can be a | |||
248 | package name, or an appropriate meta-object (a L<Moose::Meta::Class> or | |||
249 | L<Moose::Meta::Role>). | |||
250 | ||||
251 | =item * class_metaroles => \%roles | |||
252 | ||||
253 | This is a hash reference specifying which metaroles will be applied to the | |||
254 | class metaclass and its contained metaclasses and helper classes. | |||
255 | ||||
256 | Each key should in turn point to an array reference of role names. | |||
257 | ||||
258 | It 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 | ||||
282 | This is a hash reference specifying which metaroles will be applied to the | |||
283 | role metaclass and its contained metaclasses and helper classes. | |||
284 | ||||
285 | It 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 | ||||
313 | This function will apply the specified roles to the object's base class. | |||
314 | ||||
315 | =head1 BUGS | |||
316 | ||||
317 | See L<Moose/BUGS> for details on reporting bugs. | |||
318 | ||||
319 | =head1 AUTHOR | |||
320 | ||||
321 | Dave Rolsky E<lt>autarch@urth.orgE<gt> | |||
322 | ||||
323 | =head1 COPYRIGHT AND LICENSE | |||
324 | ||||
325 | Copyright 2009 by Infinity Interactive, Inc. | |||
326 | ||||
327 | L<http://www.iinteractive.com> | |||
328 | ||||
329 | This library is free software; you can redistribute it and/or modify | |||
330 | it under the same terms as Perl itself. | |||
331 | ||||
332 | =cut |