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