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