Commit | Line | Data |
231be3be |
1 | package Moose::Util::MetaRole; |
2 | |
3 | use strict; |
4 | use warnings; |
114134a5 |
5 | use Scalar::Util 'blessed'; |
231be3be |
6 | |
26a08c15 |
7 | our $VERSION = '0.93_01'; |
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 | |
231 | This function will apply roles to one or more metaclasses for the |
232 | specified class. It accepts the following parameters: |
233 | |
234 | =over 4 |
235 | |
f785aad8 |
236 | =item * for => $name |
237 | |
238 | This specifies the class or for which to alter the meta classes. This can be a |
239 | package name, or an appropriate meta-object (a L<Moose::Meta::Class> or |
240 | L<Moose::Meta::Role>). |
c59bc009 |
241 | |
f785aad8 |
242 | =item * class_metaroles => \%roles |
c59bc009 |
243 | |
f785aad8 |
244 | This is a hash reference specifying which metaroles will be applied to the |
245 | class metaclass and its contained metaclasses and helper classes. |
c59bc009 |
246 | |
f785aad8 |
247 | Each key should in turn point to an array reference of role names. |
c59bc009 |
248 | |
f785aad8 |
249 | It accepts the following keys: |
c59bc009 |
250 | |
f785aad8 |
251 | =over 8 |
8286fcd6 |
252 | |
f785aad8 |
253 | =item class |
c59bc009 |
254 | |
f785aad8 |
255 | =item attribute |
c59bc009 |
256 | |
f785aad8 |
257 | =item method |
c59bc009 |
258 | |
f785aad8 |
259 | =item wrapped_method |
260 | |
261 | =item instance |
262 | |
263 | =item constructor |
264 | |
265 | =item destructor |
266 | |
267 | =item error |
268 | |
269 | =back |
d401dc20 |
270 | |
f785aad8 |
271 | =item * role_metaroles => \%roles |
d401dc20 |
272 | |
f785aad8 |
273 | This is a hash reference specifying which metaroles will be applied to the |
274 | role metaclass and its contained metaclasses and helper classes. |
d401dc20 |
275 | |
f785aad8 |
276 | It accepts the following keys: |
277 | |
278 | =over 8 |
279 | |
280 | =item role |
281 | |
282 | =item attribute |
283 | |
284 | =item method |
285 | |
286 | =item required_method |
287 | |
288 | =item conflicting_method |
289 | |
290 | =item application_to_class |
291 | |
292 | =item application_to_role |
293 | |
294 | =item application_to_instance |
295 | |
296 | =item application_role_summation |
297 | |
298 | =back |
c59bc009 |
299 | |
300 | =back |
301 | |
f785aad8 |
302 | =head2 apply_base_class_roles( for => $class, roles => \@roles ) |
c59bc009 |
303 | |
304 | This function will apply the specified roles to the object's base class. |
305 | |
c5fc2c21 |
306 | =head1 BUGS |
307 | |
308 | See L<Moose/BUGS> for details on reporting bugs. |
309 | |
c59bc009 |
310 | =head1 AUTHOR |
311 | |
312 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
313 | |
314 | =head1 COPYRIGHT AND LICENSE |
315 | |
2840a3b2 |
316 | Copyright 2009 by Infinity Interactive, Inc. |
c59bc009 |
317 | |
318 | L<http://www.iinteractive.com> |
319 | |
320 | This library is free software; you can redistribute it and/or modify |
321 | it under the same terms as Perl itself. |
322 | |
323 | =cut |