Commit | Line | Data |
f87debb9 |
1 | package Mouse::Util::MetaRole; |
2 | use Mouse::Util; # enables strict and warnings |
733f404b |
3 | use Scalar::Util (); |
f87debb9 |
4 | |
f87debb9 |
5 | sub apply_metaclass_roles { |
733f404b |
6 | my %args = @_; |
7 | _fixup_old_style_args(\%args); |
8 | |
9 | return apply_metaroles(%args); |
10 | } |
11 | |
12 | sub apply_metaroles { |
13 | my %args = @_; |
14 | |
15 | my $for = Scalar::Util::blessed($args{for}) |
16 | ? $args{for} |
17 | : Mouse::Util::get_metaclass_by_name( $args{for} ); |
18 | |
19 | if ( Mouse::Util::is_a_metarole($for) ) { |
20 | return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); |
21 | } |
22 | else { |
23 | return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); |
24 | } |
25 | } |
26 | |
27 | sub _make_new_metaclass { |
28 | my($for, $roles, $primary) = @_; |
29 | |
30 | return $for unless keys %{$roles}; |
31 | |
32 | my $new_metaclass = exists($roles->{$primary}) |
33 | ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits |
34 | : ref $for; |
35 | |
36 | my %classes; |
37 | |
38 | for my $key ( grep { $_ ne $primary } keys %{$roles} ) { |
39 | my $metaclass; |
40 | my $attr = $for->can($metaclass = ($key . '_metaclass')) |
41 | || $for->can($metaclass = ($key . '_class')) |
42 | || $for->throw_error("Unknown metaclass '$key'"); |
f87debb9 |
43 | |
733f404b |
44 | $classes{ $metaclass } |
45 | = _make_new_class( $for->$attr(), $roles->{$key} ); |
46 | } |
47 | |
48 | return $new_metaclass->reinitialize( $for, %classes ); |
49 | } |
50 | |
51 | |
52 | sub _fixup_old_style_args { |
53 | my $args = shift; |
54 | |
55 | return if $args->{class_metaroles} || $args->{roles_metaroles}; |
56 | |
57 | $args->{for} = delete $args->{for_class} |
58 | if exists $args->{for_class}; |
59 | |
60 | my @old_keys = qw( |
61 | attribute_metaclass_roles |
62 | method_metaclass_roles |
63 | wrapped_method_metaclass_roles |
64 | instance_metaclass_roles |
65 | constructor_class_roles |
66 | destructor_class_roles |
67 | error_class_roles |
f87debb9 |
68 | |
733f404b |
69 | application_to_class_class_roles |
70 | application_to_role_class_roles |
71 | application_to_instance_class_roles |
72 | application_role_summation_class_roles |
d9659f80 |
73 | ); |
f87debb9 |
74 | |
733f404b |
75 | my $for = Scalar::Util::blessed($args->{for}) |
76 | ? $args->{for} |
77 | : Mouse::Util::get_metaclass_by_name( $args->{for} ); |
f87debb9 |
78 | |
733f404b |
79 | my $top_key; |
80 | if( Mouse::Util::is_a_metaclass($for) ){ |
81 | $top_key = 'class_metaroles'; |
f87debb9 |
82 | |
733f404b |
83 | $args->{class_metaroles}{class} = delete $args->{metaclass_roles} |
84 | if exists $args->{metaclass_roles}; |
f87debb9 |
85 | } |
733f404b |
86 | else { |
87 | $top_key = 'role_metaroles'; |
f87debb9 |
88 | |
733f404b |
89 | $args->{role_metaroles}{role} = delete $args->{metaclass_roles} |
90 | if exists $args->{metaclass_roles}; |
91 | } |
92 | |
93 | for my $old_key (@old_keys) { |
94 | my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/; |
95 | |
96 | $args->{$top_key}{$new_key} = delete $args->{$old_key} |
97 | if exists $args->{$old_key}; |
98 | } |
99 | |
100 | return; |
f87debb9 |
101 | } |
102 | |
733f404b |
103 | |
f87debb9 |
104 | sub apply_base_class_roles { |
105 | my %options = @_; |
106 | |
107 | my $for = $options{for_class}; |
108 | |
109 | my $meta = Mouse::Util::class_of($for); |
110 | |
111 | my $new_base = _make_new_class( |
112 | $for, |
113 | $options{roles}, |
114 | [ $meta->superclasses() ], |
115 | ); |
116 | |
117 | $meta->superclasses($new_base) |
118 | if $new_base ne $meta->name(); |
119 | return; |
120 | } |
121 | |
f87debb9 |
122 | sub _make_new_class { |
123 | my($existing_class, $roles, $superclasses) = @_; |
124 | |
d9659f80 |
125 | if(!$superclasses){ |
126 | return $existing_class if !$roles; |
f87debb9 |
127 | |
d9659f80 |
128 | my $meta = Mouse::Meta::Class->initialize($existing_class); |
f87debb9 |
129 | |
d9659f80 |
130 | return $existing_class |
131 | if !grep { !ref($_) && !$meta->does_role($_) } @{$roles}; |
132 | } |
f87debb9 |
133 | |
134 | return Mouse::Meta::Class->create_anon_class( |
135 | superclasses => $superclasses ? $superclasses : [$existing_class], |
136 | roles => $roles, |
137 | cache => 1, |
138 | )->name(); |
139 | } |
140 | |
141 | 1; |
f87debb9 |
142 | __END__ |
143 | |
144 | =head1 NAME |
145 | |
146 | Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class |
147 | |
148 | =head1 SYNOPSIS |
149 | |
150 | package MyApp::Mouse; |
151 | |
152 | use Mouse (); |
153 | use Mouse::Exporter; |
154 | use Mouse::Util::MetaRole; |
155 | |
156 | use MyApp::Role::Meta::Class; |
157 | use MyApp::Role::Meta::Method::Constructor; |
158 | use MyApp::Role::Object; |
159 | |
160 | Mouse::Exporter->setup_import_methods( also => 'Mouse' ); |
161 | |
162 | sub init_meta { |
163 | shift; |
241dd25c |
164 | my %args = @_; |
f87debb9 |
165 | |
241dd25c |
166 | Mouse->init_meta(%args); |
f87debb9 |
167 | |
241dd25c |
168 | Mouse::Util::MetaRole::apply_metaroles( |
169 | for => $args{for_class}, |
170 | class_metaroles => { |
171 | class => ['MyApp::Role::Meta::Class'], |
172 | constructor => ['MyApp::Role::Meta::Method::Constructor'], |
173 | }, |
f87debb9 |
174 | ); |
175 | |
176 | Mouse::Util::MetaRole::apply_base_class_roles( |
241dd25c |
177 | for => $args{for_class}, |
178 | roles => ['MyApp::Role::Object'], |
f87debb9 |
179 | ); |
180 | |
241dd25c |
181 | return $args{for_class}->meta(); |
f87debb9 |
182 | } |
183 | |
184 | =head1 DESCRIPTION |
185 | |
186 | This utility module is designed to help authors of Mouse extensions |
187 | write extensions that are able to cooperate with other Mouse |
188 | extensions. To do this, you must write your extensions as roles, which |
189 | can then be dynamically applied to the caller's metaclasses. |
190 | |
191 | This module makes sure to preserve any existing superclasses and roles |
192 | already set for the meta objects, which means that any number of |
193 | extensions can apply roles in any order. |
194 | |
195 | =head1 USAGE |
196 | |
197 | B<It is very important that you only call this module's functions when |
198 | your module is imported by the caller>. The process of applying roles |
199 | to the metaclass reinitializes the metaclass object, which wipes out |
200 | any existing attributes already defined. However, as long as you do |
201 | this when your module is imported, the caller should not have any |
202 | attributes defined yet. |
203 | |
204 | The easiest way to ensure that this happens is to use |
205 | L<Mouse::Exporter>, which can generate the appropriate C<init_meta> |
206 | method for you, and make sure it is called when imported. |
207 | |
208 | =head1 FUNCTIONS |
209 | |
210 | This module provides two functions. |
211 | |
241dd25c |
212 | =head2 apply_metaroles( ... ) |
f87debb9 |
213 | |
214 | This function will apply roles to one or more metaclasses for the |
215 | specified class. It accepts the following parameters: |
216 | |
217 | =over 4 |
218 | |
241dd25c |
219 | =item * for => $name |
f87debb9 |
220 | |
241dd25c |
221 | This specifies the class or for which to alter the meta classes. This can be a |
222 | package name, or an appropriate meta-object (a L<Mouse::Meta::Class> or |
223 | L<Mouse::Meta::Role>). |
f87debb9 |
224 | |
241dd25c |
225 | =item * class_metaroles => \%roles |
f87debb9 |
226 | |
241dd25c |
227 | This is a hash reference specifying which metaroles will be applied to the |
228 | class metaclass and its contained metaclasses and helper classes. |
f87debb9 |
229 | |
241dd25c |
230 | Each key should in turn point to an array reference of role names. |
f87debb9 |
231 | |
241dd25c |
232 | It accepts the following keys: |
f87debb9 |
233 | |
241dd25c |
234 | =over 8 |
f87debb9 |
235 | |
241dd25c |
236 | =item class |
237 | |
238 | =item attribute |
239 | |
240 | =item method |
241 | |
242 | =item constructor |
243 | |
244 | =item destructor |
245 | |
246 | =back |
247 | |
248 | =item * role_metaroles => \%roles |
249 | |
250 | This is a hash reference specifying which metaroles will be applied to the |
251 | role metaclass and its contained metaclasses and helper classes. |
252 | |
253 | It accepts the following keys: |
254 | |
255 | =over 8 |
256 | |
257 | =item role |
258 | |
259 | =item method |
260 | |
261 | =back |
f87debb9 |
262 | |
263 | =back |
264 | |
241dd25c |
265 | =head2 apply_base_class_roles( for => $class, roles => \@roles ) |
f87debb9 |
266 | |
267 | This function will apply the specified roles to the object's base class. |
268 | |
a9cf013d |
269 | =head1 SEE ALSO |
f87debb9 |
270 | |
271 | L<Moose::Util::MetaRole> |
272 | |
273 | =cut |