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