Bump version to 1.9900 for new version numbering scheme
[gitmo/Moose.git] / lib / Moose / Util / MetaRole.pm
CommitLineData
231be3be 1package Moose::Util::MetaRole;
2
3use strict;
4use warnings;
114134a5 5use Scalar::Util 'blessed';
231be3be 6
bb8ef151 7our $VERSION = '1.9900';
ae18d5ec 8$VERSION = eval $VERSION;
9our $AUTHORITY = 'cpan:STEVAN';
10
231be3be 11use List::MoreUtils qw( all );
f785aad8 12use List::Util qw( first );
3b400403 13use Moose::Deprecated;
8f05895e 14
231be3be 15sub apply_metaclass_roles {
3b400403 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
f785aad8 22 goto &apply_metaroles;
23}
24
25sub apply_metaroles {
26 my %args = @_;
27
28 _fixup_old_style_args(\%args);
39e7855c 29
f785aad8 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' );
231be3be 40 }
f785aad8 41}
42
43sub _fixup_old_style_args {
44 my $args = shift;
45
3b400403 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 );
f785aad8 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 );
231be3be 71
f785aad8 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;
231be3be 99}
100
101sub _make_new_metaclass {
102 my $for = shift;
f785aad8 103 my $roles = shift;
104 my $primary = shift;
105
106 return $for unless keys %{$roles};
231be3be 107
108 my $new_metaclass
f785aad8 109 = exists $roles->{$primary}
110 ? _make_new_class( ref $for, $roles->{$primary} )
111 : blessed $for;
231be3be 112
f785aad8 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;
231be3be 131}
132
133sub apply_base_class_roles {
f785aad8 134 my %args = @_;
231be3be 135
f785aad8 136 my $for = $args{for} || $args{for_class};
231be3be 137
95f64261 138 my $meta = Class::MOP::class_of($for);
231be3be 139
140 my $new_base = _make_new_class(
141 $for,
f785aad8 142 $args{roles},
231be3be 143 [ $meta->superclasses() ],
144 );
145
146 $meta->superclasses($new_base)
147 if $new_base ne $meta->name();
148}
149
150sub _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
8f05895e 157 my $meta = Class::MOP::Class->initialize($existing_class);
231be3be 158
159 return $existing_class
386c056b 160 if $meta->can('does_role') && all { $meta->does_role($_) }
161 grep { !ref $_ } @{$roles};
231be3be 162
163 return Moose::Meta::Class->create_anon_class(
164 superclasses => $superclasses,
165 roles => $roles,
166 cache => 1,
167 )->name();
168}
169
1701;
c59bc009 171
172__END__
173
174=head1 NAME
175
176Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
177
178=head1 SYNOPSIS
179
180 package MyApp::Moose;
181
c59bc009 182 use Moose ();
183 use Moose::Exporter;
49a86a99 184 use Moose::Util::MetaRole;
c59bc009 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;
f785aad8 194 my %args = @_;
c59bc009 195
f785aad8 196 Moose->init_meta(%args);
c59bc009 197
f785aad8 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 },
c59bc009 204 );
205
206 Moose::Util::MetaRole::apply_base_class_roles(
f785aad8 207 for => $args{for_class},
208 roles => ['MyApp::Role::Object'],
c59bc009 209 );
210
f785aad8 211 return $args{for_class}->meta();
c59bc009 212 }
213
214=head1 DESCRIPTION
215
216This utility module is designed to help authors of Moose extensions
217write extensions that are able to cooperate with other Moose
218extensions. To do this, you must write your extensions as roles, which
52a919fe 219can then be dynamically applied to the caller's metaclasses.
c59bc009 220
221This module makes sure to preserve any existing superclasses and roles
222already set for the meta objects, which means that any number of
223extensions can apply roles in any order.
224
225=head1 USAGE
226
110bb412 227The easiest way to use this module is through L<Moose::Exporter>, which can
228generate the appropriate C<init_meta> method for you, and make sure it is
229called when imported.
c59bc009 230
231=head1 FUNCTIONS
232
233This module provides two functions.
234
f785aad8 235=head2 apply_metaroles( ... )
c59bc009 236
8f6b08fd 237This function will apply roles to one or more metaclasses for the specified
238class. It will return a new metaclass object for the class or role passed in
239the "for" parameter.
240
241It accepts the following parameters:
c59bc009 242
243=over 4
244
f785aad8 245=item * for => $name
246
247This specifies the class or for which to alter the meta classes. This can be a
248package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
249L<Moose::Meta::Role>).
c59bc009 250
f785aad8 251=item * class_metaroles => \%roles
c59bc009 252
f785aad8 253This is a hash reference specifying which metaroles will be applied to the
254class metaclass and its contained metaclasses and helper classes.
c59bc009 255
f785aad8 256Each key should in turn point to an array reference of role names.
c59bc009 257
f785aad8 258It accepts the following keys:
c59bc009 259
f785aad8 260=over 8
8286fcd6 261
f785aad8 262=item class
c59bc009 263
f785aad8 264=item attribute
c59bc009 265
f785aad8 266=item method
c59bc009 267
f785aad8 268=item wrapped_method
269
270=item instance
271
272=item constructor
273
274=item destructor
275
276=item error
277
278=back
d401dc20 279
f785aad8 280=item * role_metaroles => \%roles
d401dc20 281
f785aad8 282This is a hash reference specifying which metaroles will be applied to the
283role metaclass and its contained metaclasses and helper classes.
d401dc20 284
f785aad8 285It 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
c59bc009 308
309=back
310
f785aad8 311=head2 apply_base_class_roles( for => $class, roles => \@roles )
c59bc009 312
313This function will apply the specified roles to the object's base class.
314
c5fc2c21 315=head1 BUGS
316
317See L<Moose/BUGS> for details on reporting bugs.
318
c59bc009 319=head1 AUTHOR
320
321Dave Rolsky E<lt>autarch@urth.orgE<gt>
322
323=head1 COPYRIGHT AND LICENSE
324
2840a3b2 325Copyright 2009 by Infinity Interactive, Inc.
c59bc009 326
327L<http://www.iinteractive.com>
328
329This library is free software; you can redistribute it and/or modify
330it under the same terms as Perl itself.
331
332=cut