Commit | Line | Data |
231be3be |
1 | package Moose::Util::MetaRole; |
2 | |
3 | use strict; |
4 | use warnings; |
114134a5 |
5 | use Scalar::Util 'blessed'; |
231be3be |
6 | |
60f08160 |
7 | our $VERSION = '1.09'; |
ae18d5ec |
8 | $VERSION = eval $VERSION; |
9 | our $AUTHORITY = 'cpan:STEVAN'; |
10 | |
231be3be |
11 | use List::MoreUtils qw( all ); |
f785aad8 |
12 | use List::Util qw( first ); |
3b400403 |
13 | use Moose::Deprecated; |
8f05895e |
14 | |
231be3be |
15 | sub apply_metaclass_roles { |
3b400403 |
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 | |
f785aad8 |
22 | goto &apply_metaroles; |
23 | } |
24 | |
25 | sub apply_metaroles { |
26 | my %args = @_; |
27 | |
28 | _fixup_old_style_args(\%args); |
29 | Carp::cluck('applying') if $::D; |
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' ); |
231be3be |
40 | } |
f785aad8 |
41 | } |
42 | |
43 | sub _fixup_old_style_args { |
44 | my $args = shift; |
45 | |
3b400403 |
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 | ); |
f785aad8 |
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 | ); |
231be3be |
71 | |
f785aad8 |
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; |
231be3be |
99 | } |
100 | |
101 | sub _make_new_metaclass { |
102 | my $for = shift; |
f785aad8 |
103 | my $roles = shift; |
104 | my $primary = shift; |
105 | |
106 | return $for unless keys %{$roles}; |
231be3be |
107 | |
108 | my $new_metaclass |
f785aad8 |
109 | = exists $roles->{$primary} |
110 | ? _make_new_class( ref $for, $roles->{$primary} ) |
111 | : blessed $for; |
231be3be |
112 | |
f785aad8 |
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; |
231be3be |
131 | } |
132 | |
133 | sub apply_base_class_roles { |
f785aad8 |
134 | my %args = @_; |
231be3be |
135 | |
f785aad8 |
136 | my $for = $args{for} || $args{for_class}; |
231be3be |
137 | |
95f64261 |
138 | my $meta = Class::MOP::class_of($for); |
231be3be |
139 | |
140 | my $new_base = _make_new_class( |
141 | $for, |
f785aad8 |
142 | $args{roles}, |
231be3be |
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 | |
8f05895e |
157 | my $meta = Class::MOP::Class->initialize($existing_class); |
231be3be |
158 | |
159 | return $existing_class |
386c056b |
160 | if $meta->can('does_role') && all { $meta->does_role($_) } |
161 | grep { !ref $_ } @{$roles}; |
231be3be |
162 | |
163 | return Moose::Meta::Class->create_anon_class( |
164 | superclasses => $superclasses, |
165 | roles => $roles, |
166 | cache => 1, |
167 | )->name(); |
168 | } |
169 | |
170 | 1; |
c59bc009 |
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 | |
c59bc009 |
182 | use Moose (); |
183 | use Moose::Exporter; |
49a86a99 |
184 | use Moose::Util::MetaRole; |
c59bc009 |
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; |
f785aad8 |
194 | my %args = @_; |
c59bc009 |
195 | |
f785aad8 |
196 | Moose->init_meta(%args); |
c59bc009 |
197 | |
f785aad8 |
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 | }, |
c59bc009 |
204 | ); |
205 | |
206 | Moose::Util::MetaRole::apply_base_class_roles( |
f785aad8 |
207 | for => $args{for_class}, |
208 | roles => ['MyApp::Role::Object'], |
c59bc009 |
209 | ); |
210 | |
f785aad8 |
211 | return $args{for_class}->meta(); |
c59bc009 |
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 |
52a919fe |
219 | can then be dynamically applied to the caller's metaclasses. |
c59bc009 |
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 | B<It is very important that you only call this module's functions when |
228 | your module is imported by the caller>. The process of applying roles |
229 | to the metaclass reinitializes the metaclass object, which wipes out |
230 | any existing attributes already defined. However, as long as you do |
231 | this when your module is imported, the caller should not have any |
232 | attributes defined yet. |
233 | |
234 | The easiest way to ensure that this happens is to use |
95056a1e |
235 | L<Moose::Exporter>, which can generate the appropriate C<init_meta> |
236 | method for you, and make sure it is called when imported. |
c59bc009 |
237 | |
238 | =head1 FUNCTIONS |
239 | |
240 | This module provides two functions. |
241 | |
f785aad8 |
242 | =head2 apply_metaroles( ... ) |
c59bc009 |
243 | |
8f6b08fd |
244 | This function will apply roles to one or more metaclasses for the specified |
245 | class. It will return a new metaclass object for the class or role passed in |
246 | the "for" parameter. |
247 | |
248 | It accepts the following parameters: |
c59bc009 |
249 | |
250 | =over 4 |
251 | |
f785aad8 |
252 | =item * for => $name |
253 | |
254 | This specifies the class or for which to alter the meta classes. This can be a |
255 | package name, or an appropriate meta-object (a L<Moose::Meta::Class> or |
256 | L<Moose::Meta::Role>). |
c59bc009 |
257 | |
f785aad8 |
258 | =item * class_metaroles => \%roles |
c59bc009 |
259 | |
f785aad8 |
260 | This is a hash reference specifying which metaroles will be applied to the |
261 | class metaclass and its contained metaclasses and helper classes. |
c59bc009 |
262 | |
f785aad8 |
263 | Each key should in turn point to an array reference of role names. |
c59bc009 |
264 | |
f785aad8 |
265 | It accepts the following keys: |
c59bc009 |
266 | |
f785aad8 |
267 | =over 8 |
8286fcd6 |
268 | |
f785aad8 |
269 | =item class |
c59bc009 |
270 | |
f785aad8 |
271 | =item attribute |
c59bc009 |
272 | |
f785aad8 |
273 | =item method |
c59bc009 |
274 | |
f785aad8 |
275 | =item wrapped_method |
276 | |
277 | =item instance |
278 | |
279 | =item constructor |
280 | |
281 | =item destructor |
282 | |
283 | =item error |
284 | |
285 | =back |
d401dc20 |
286 | |
f785aad8 |
287 | =item * role_metaroles => \%roles |
d401dc20 |
288 | |
f785aad8 |
289 | This is a hash reference specifying which metaroles will be applied to the |
290 | role metaclass and its contained metaclasses and helper classes. |
d401dc20 |
291 | |
f785aad8 |
292 | It accepts the following keys: |
293 | |
294 | =over 8 |
295 | |
296 | =item role |
297 | |
298 | =item attribute |
299 | |
300 | =item method |
301 | |
302 | =item required_method |
303 | |
304 | =item conflicting_method |
305 | |
306 | =item application_to_class |
307 | |
308 | =item application_to_role |
309 | |
310 | =item application_to_instance |
311 | |
312 | =item application_role_summation |
313 | |
314 | =back |
c59bc009 |
315 | |
316 | =back |
317 | |
f785aad8 |
318 | =head2 apply_base_class_roles( for => $class, roles => \@roles ) |
c59bc009 |
319 | |
320 | This function will apply the specified roles to the object's base class. |
321 | |
c5fc2c21 |
322 | =head1 BUGS |
323 | |
324 | See L<Moose/BUGS> for details on reporting bugs. |
325 | |
c59bc009 |
326 | =head1 AUTHOR |
327 | |
328 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
329 | |
330 | =head1 COPYRIGHT AND LICENSE |
331 | |
2840a3b2 |
332 | Copyright 2009 by Infinity Interactive, Inc. |
c59bc009 |
333 | |
334 | L<http://www.iinteractive.com> |
335 | |
336 | This library is free software; you can redistribute it and/or modify |
337 | it under the same terms as Perl itself. |
338 | |
339 | =cut |