Bump version to 1.9900 for new version numbering scheme
[gitmo/Moose.git] / lib / Moose / Util / MetaRole.pm
1 package Moose::Util::MetaRole;
2
3 use strict;
4 use warnings;
5 use Scalar::Util 'blessed';
6
7 our $VERSION   = '1.9900';
8 $VERSION = eval $VERSION;
9 our $AUTHORITY = 'cpan:STEVAN';
10
11 use List::MoreUtils qw( all );
12 use List::Util qw( first );
13 use Moose::Deprecated;
14
15 sub apply_metaclass_roles {
16     Moose::Deprecated::deprecated(
17         feature => 'pre-0.94 MetaRole API',
18         message =>
19             'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
20     );
21
22     goto &apply_metaroles;
23 }
24
25 sub apply_metaroles {
26     my %args = @_;
27
28     _fixup_old_style_args(\%args);
29
30     my $for
31         = blessed $args{for}
32         ? $args{for}
33         : Class::MOP::class_of( $args{for} );
34
35     if ( $for->isa('Moose::Meta::Role') ) {
36         return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
37     }
38     else {
39         return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
40     }
41 }
42
43 sub _fixup_old_style_args {
44     my $args = shift;
45
46     return if $args->{class_metaroles} || $args->{role_metaroles};
47
48     Moose::Deprecated::deprecated(
49         feature => 'pre-0.94 MetaRole API',
50         message =>
51             'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated'
52     );
53
54     $args->{for} = delete $args->{for_class}
55         if exists $args->{for_class};
56
57     my @old_keys = qw(
58         attribute_metaclass_roles
59         method_metaclass_roles
60         wrapped_method_metaclass_roles
61         instance_metaclass_roles
62         constructor_class_roles
63         destructor_class_roles
64         error_class_roles
65
66         application_to_class_class_roles
67         application_to_role_class_roles
68         application_to_instance_class_roles
69         application_role_summation_class_roles
70     );
71
72     my $for
73         = blessed $args->{for}
74         ? $args->{for}
75         : Class::MOP::class_of( $args->{for} );
76
77     my $top_key;
78     if ( $for->isa('Moose::Meta::Class') ) {
79         $top_key = 'class_metaroles';
80
81         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
82             if exists $args->{metaclass_roles};
83     }
84     else {
85         $top_key = 'role_metaroles';
86
87         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
88             if exists $args->{metaclass_roles};
89     }
90
91     for my $old_key (@old_keys) {
92         my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
93
94         $args->{$top_key}{$new_key} = delete $args->{$old_key}
95             if exists $args->{$old_key};
96     }
97
98     return;
99 }
100
101 sub _make_new_metaclass {
102     my $for     = shift;
103     my $roles   = shift;
104     my $primary = shift;
105
106     return $for unless keys %{$roles};
107
108     my $new_metaclass
109         = exists $roles->{$primary}
110         ? _make_new_class( ref $for, $roles->{$primary} )
111         : blessed $for;
112
113     my %classes;
114
115     for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
116         my $attr = first {$_}
117             map { $for->meta->find_attribute_by_name($_) } (
118             $key . '_metaclass',
119             $key . '_class'
120         );
121
122         my $reader = $attr->get_read_method;
123
124         $classes{ $attr->init_arg }
125             = _make_new_class( $for->$reader(), $roles->{$key} );
126     }
127
128     my $new_meta = $new_metaclass->reinitialize( $for, %classes );
129
130     return $new_meta;
131 }
132
133 sub apply_base_class_roles {
134     my %args = @_;
135
136     my $for = $args{for} || $args{for_class};
137
138     my $meta = Class::MOP::class_of($for);
139
140     my $new_base = _make_new_class(
141         $for,
142         $args{roles},
143         [ $meta->superclasses() ],
144     );
145
146     $meta->superclasses($new_base)
147         if $new_base ne $meta->name();
148 }
149
150 sub _make_new_class {
151     my $existing_class = shift;
152     my $roles          = shift;
153     my $superclasses   = shift || [$existing_class];
154
155     return $existing_class unless $roles;
156
157     my $meta = Class::MOP::Class->initialize($existing_class);
158
159     return $existing_class
160         if $meta->can('does_role') && all  { $meta->does_role($_) }
161                                       grep { !ref $_ } @{$roles};
162
163     return Moose::Meta::Class->create_anon_class(
164         superclasses => $superclasses,
165         roles        => $roles,
166         cache        => 1,
167     )->name();
168 }
169
170 1;
171
172 __END__
173
174 =head1 NAME
175
176 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
177
178 =head1 SYNOPSIS
179
180   package MyApp::Moose;
181
182   use Moose ();
183   use Moose::Exporter;
184   use Moose::Util::MetaRole;
185
186   use MyApp::Role::Meta::Class;
187   use MyApp::Role::Meta::Method::Constructor;
188   use MyApp::Role::Object;
189
190   Moose::Exporter->setup_import_methods( also => 'Moose' );
191
192   sub init_meta {
193       shift;
194       my %args = @_;
195
196       Moose->init_meta(%args);
197
198       Moose::Util::MetaRole::apply_metaroles(
199           for             => $args{for_class},
200           class_metaroles => {
201               class => => ['MyApp::Role::Meta::Class'],
202               constructor => ['MyApp::Role::Meta::Method::Constructor'],
203           },
204       );
205
206       Moose::Util::MetaRole::apply_base_class_roles(
207           for   => $args{for_class},
208           roles => ['MyApp::Role::Object'],
209       );
210
211       return $args{for_class}->meta();
212   }
213
214 =head1 DESCRIPTION
215
216 This utility module is designed to help authors of Moose extensions
217 write extensions that are able to cooperate with other Moose
218 extensions. To do this, you must write your extensions as roles, which
219 can then be dynamically applied to the caller's metaclasses.
220
221 This module makes sure to preserve any existing superclasses and roles
222 already set for the meta objects, which means that any number of
223 extensions can apply roles in any order.
224
225 =head1 USAGE
226
227 The easiest way to use this module is through L<Moose::Exporter>, which can
228 generate the appropriate C<init_meta> method for you, and make sure it is
229 called when imported.
230
231 =head1 FUNCTIONS
232
233 This module provides two functions.
234
235 =head2 apply_metaroles( ... )
236
237 This function will apply roles to one or more metaclasses for the specified
238 class. It will return a new metaclass object for the class or role passed in
239 the "for" parameter.
240
241 It accepts the following parameters:
242
243 =over 4
244
245 =item * for => $name
246
247 This specifies the class or for which to alter the meta classes. This can be a
248 package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
249 L<Moose::Meta::Role>).
250
251 =item * class_metaroles => \%roles
252
253 This is a hash reference specifying which metaroles will be applied to the
254 class metaclass and its contained metaclasses and helper classes.
255
256 Each key should in turn point to an array reference of role names.
257
258 It accepts the following keys:
259
260 =over 8
261
262 =item class
263
264 =item attribute
265
266 =item method
267
268 =item wrapped_method
269
270 =item instance
271
272 =item constructor
273
274 =item destructor
275
276 =item error
277
278 =back
279
280 =item * role_metaroles => \%roles
281
282 This is a hash reference specifying which metaroles will be applied to the
283 role metaclass and its contained metaclasses and helper classes.
284
285 It accepts the following keys:
286
287 =over 8
288
289 =item role
290
291 =item attribute
292
293 =item method
294
295 =item required_method
296
297 =item conflicting_method
298
299 =item application_to_class
300
301 =item application_to_role
302
303 =item application_to_instance
304
305 =item application_role_summation
306
307 =back
308
309 =back
310
311 =head2 apply_base_class_roles( for => $class, roles => \@roles )
312
313 This function will apply the specified roles to the object's base class.
314
315 =head1 BUGS
316
317 See L<Moose/BUGS> for details on reporting bugs.
318
319 =head1 AUTHOR
320
321 Dave Rolsky E<lt>autarch@urth.orgE<gt>
322
323 =head1 COPYRIGHT AND LICENSE
324
325 Copyright 2009 by Infinity Interactive, Inc.
326
327 L<http://www.iinteractive.com>
328
329 This library is free software; you can redistribute it and/or modify
330 it under the same terms as Perl itself.
331
332 =cut