Commit | Line | Data |
231be3be |
1 | package Moose::Util::MetaRole; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use List::MoreUtils qw( all ); |
7 | |
8f05895e |
8 | my @Classes = qw( constructor_class destructor_class error_class ); |
9 | |
231be3be |
10 | sub apply_metaclass_roles { |
11 | my %options = @_; |
12 | |
13 | my $for = $options{for_class}; |
14 | |
8f05895e |
15 | my %old_classes = map { $_ => $for->meta->$_ } @Classes; |
231be3be |
16 | |
8f05895e |
17 | my $meta = _make_new_metaclass( $for, \%options ); |
231be3be |
18 | |
8f05895e |
19 | for my $c (@Classes) { |
20 | if ( $options{ $c . '_roles' } ) { |
21 | my $class = _make_new_class( |
22 | $meta->$c(), |
23 | $options{ $c . '_roles' } |
24 | ); |
231be3be |
25 | |
8f05895e |
26 | $meta->$c($class); |
27 | } |
28 | else { |
29 | $meta->$c( $old_classes{$c} ); |
30 | } |
231be3be |
31 | } |
32 | |
33 | return $meta; |
34 | } |
35 | |
36 | sub _make_new_metaclass { |
37 | my $for = shift; |
38 | my $options = shift; |
39 | |
40 | return $for->meta() |
41 | unless grep { exists $options->{ $_ . '_roles' } } |
42 | qw( |
43 | metaclass |
44 | attribute_metaclass |
45 | method_metaclass |
46 | instance_metaclass |
47 | ); |
48 | |
49 | my $new_metaclass |
50 | = _make_new_class( ref $for->meta(), $options->{metaclass_roles} ); |
51 | |
52 | my $old_meta = $for->meta(); |
53 | |
72d15b83 |
54 | # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class |
231be3be |
55 | my %classes = map { |
56 | $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } ) |
72d15b83 |
57 | } |
58 | grep { $old_meta->can($_) } |
59 | qw( |
231be3be |
60 | attribute_metaclass |
61 | method_metaclass |
62 | instance_metaclass |
63 | ); |
64 | |
65 | return $new_metaclass->reinitialize( $for, %classes ); |
66 | } |
67 | |
68 | sub apply_base_class_roles { |
69 | my %options = @_; |
70 | |
71 | my $for = $options{for_class}; |
72 | |
73 | my $meta = $for->meta(); |
74 | |
75 | my $new_base = _make_new_class( |
76 | $for, |
77 | $options{roles}, |
78 | [ $meta->superclasses() ], |
79 | ); |
80 | |
81 | $meta->superclasses($new_base) |
82 | if $new_base ne $meta->name(); |
83 | } |
84 | |
85 | sub _make_new_class { |
86 | my $existing_class = shift; |
87 | my $roles = shift; |
88 | my $superclasses = shift || [$existing_class]; |
89 | |
90 | return $existing_class unless $roles; |
91 | |
8f05895e |
92 | my $meta = Class::MOP::Class->initialize($existing_class); |
231be3be |
93 | |
94 | return $existing_class |
95 | if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles}; |
96 | |
97 | return Moose::Meta::Class->create_anon_class( |
98 | superclasses => $superclasses, |
99 | roles => $roles, |
100 | cache => 1, |
101 | )->name(); |
102 | } |
103 | |
104 | 1; |
c59bc009 |
105 | |
106 | __END__ |
107 | |
108 | =head1 NAME |
109 | |
110 | Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class |
111 | |
112 | =head1 SYNOPSIS |
113 | |
114 | package MyApp::Moose; |
115 | |
116 | use strict; |
117 | use warnings; |
118 | |
119 | use Moose (); |
120 | use Moose::Exporter; |
121 | use Moose::Util::Meta::Role; |
122 | |
123 | use MyApp::Role::Meta::Class; |
124 | use MyApp::Role::Meta::Method::Constructor; |
125 | use MyApp::Role::Object; |
126 | |
127 | Moose::Exporter->setup_import_methods( also => 'Moose' ); |
128 | |
129 | sub init_meta { |
130 | shift; |
131 | my %options = @_; |
132 | |
133 | Moose->init_meta(%options); |
134 | |
135 | Moose::Util::MetaRole::apply_metaclass_roles( |
136 | for_class => $options{for_class}, |
137 | metaclass_roles => ['MyApp::Role::Meta::Class'], |
138 | constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'], |
139 | ); |
140 | |
141 | Moose::Util::MetaRole::apply_base_class_roles( |
142 | for_class => $options{for_class}, |
143 | roles => ['MyApp::Role::Object'], |
144 | ); |
145 | |
146 | return $options{for_class}->meta(); |
147 | } |
148 | |
149 | =head1 DESCRIPTION |
150 | |
dd9a6d87 |
151 | B<The whole concept behind this module is still considered |
152 | experimental, and it could go away in the future!> |
153 | |
c59bc009 |
154 | This utility module is designed to help authors of Moose extensions |
155 | write extensions that are able to cooperate with other Moose |
156 | extensions. To do this, you must write your extensions as roles, which |
157 | can then be dynamically applyied to the caller's metaclasses. |
158 | |
159 | This module makes sure to preserve any existing superclasses and roles |
160 | already set for the meta objects, which means that any number of |
161 | extensions can apply roles in any order. |
162 | |
163 | =head1 USAGE |
164 | |
165 | B<It is very important that you only call this module's functions when |
166 | your module is imported by the caller>. The process of applying roles |
167 | to the metaclass reinitializes the metaclass object, which wipes out |
168 | any existing attributes already defined. However, as long as you do |
169 | this when your module is imported, the caller should not have any |
170 | attributes defined yet. |
171 | |
172 | The easiest way to ensure that this happens is to use |
173 | L<Moose::Exporter> and provide an C<init_meta> method that will be |
174 | called when imported. |
175 | |
176 | =head1 FUNCTIONS |
177 | |
178 | This module provides two functions. |
179 | |
180 | =head2 apply_metaclass_roles( ... ) |
181 | |
182 | This function will apply roles to one or more metaclasses for the |
183 | specified class. It accepts the following parameters: |
184 | |
185 | =over 4 |
186 | |
187 | =item * for_class => $name |
188 | |
189 | This specifies the class for which to alter the meta classes. |
190 | |
191 | =item * metaclass_roles => \@roles |
192 | |
193 | =item * attribute_metaclass_roles => \@roles |
194 | |
195 | =item * method_metaclass_roles => \@roles |
196 | |
197 | =item * instance_metaclass_roles => \@roles |
198 | |
199 | =item * constructor_class_roles => \@roles |
200 | |
201 | =item * destructor_class_roles => \@roles |
202 | |
203 | These parameter all specify one or more roles to be applied to the |
204 | specified metaclass. You can pass any or all of these parameters at |
205 | once. |
206 | |
207 | =back |
208 | |
209 | =head2 apply_base_class_roles( for_class => $class, roles => \@roles ) |
210 | |
211 | This function will apply the specified roles to the object's base class. |
212 | |
eaeacdd6 |
213 | =head1 PROBLEMS WITH METACLASS ROLES AND SUBCLASS |
214 | |
215 | Because of the way this module works, there is an ordering problem |
216 | which occurs in certain situations. This sequence of events causes an |
217 | error: |
218 | |
219 | =over 4 |
220 | |
221 | =item 1. |
222 | |
223 | There is a class (ClassA) which uses some extension(s) that apply |
224 | roles to the metaclass. |
225 | |
226 | =item 2. |
227 | |
228 | You have another class (ClassB) which wants to subclass ClassA and |
229 | apply some more extensions. |
230 | |
231 | =back |
232 | |
233 | Normally, the call to C<extends> will happen at run time, I<after> the |
234 | additional extensions are applied. This causes an error when we try to |
235 | make the metaclass for ClassB compatible with the metaclass for |
236 | ClassA. |
237 | |
238 | We hope to be able to fix this in the future. |
239 | |
240 | For now the workaround is for ClassB to make sure it extends ClassA |
241 | I<before> it loads extensions: |
242 | |
243 | package ClassB; |
244 | |
245 | use Moose; |
246 | |
247 | BEGIN { extends 'ClassA' } |
248 | |
249 | use MooseX::SomeExtension; |
250 | |
c59bc009 |
251 | =head1 AUTHOR |
252 | |
253 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
254 | |
255 | =head1 COPYRIGHT AND LICENSE |
256 | |
257 | Copyright 2008 by Infinity Interactive, Inc. |
258 | |
259 | L<http://www.iinteractive.com> |
260 | |
261 | This library is free software; you can redistribute it and/or modify |
262 | it under the same terms as Perl itself. |
263 | |
264 | =cut |