1 package Moose::Util::MetaRole;
5 use Scalar::Util 'blessed';
8 $VERSION = eval $VERSION;
9 our $AUTHORITY = 'cpan:STEVAN';
11 use List::MoreUtils qw( all );
12 use List::Util qw( first );
14 sub apply_metaclass_roles {
15 goto &apply_metaroles;
21 _fixup_old_style_args(\%args);
22 Carp::cluck('applying') if $::D;
26 : Class::MOP::class_of( $args{for} );
28 if ( $for->isa('Moose::Meta::Role') ) {
29 return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
32 return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
36 sub _fixup_old_style_args {
39 return if $args->{class_metaroles} || $args->{roles_metaroles};
41 $args->{for} = delete $args->{for_class}
42 if exists $args->{for_class};
45 attribute_metaclass_roles
46 method_metaclass_roles
47 wrapped_method_metaclass_roles
48 instance_metaclass_roles
49 constructor_class_roles
50 destructor_class_roles
53 application_to_class_class_roles
54 application_to_role_class_roles
55 application_to_instance_class_roles
56 application_role_summation_class_roles
60 = blessed $args->{for}
62 : Class::MOP::class_of( $args->{for} );
65 if ( $for->isa('Moose::Meta::Class') ) {
66 $top_key = 'class_metaroles';
68 $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
69 if exists $args->{metaclass_roles};
72 $top_key = 'role_metaroles';
74 $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
75 if exists $args->{metaclass_roles};
78 for my $old_key (@old_keys) {
79 my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
81 $args->{$top_key}{$new_key} = delete $args->{$old_key}
82 if exists $args->{$old_key};
88 sub _make_new_metaclass {
93 return $for unless keys %{$roles};
96 = exists $roles->{$primary}
97 ? _make_new_class( ref $for, $roles->{$primary} )
102 for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
103 my $attr = first {$_}
104 map { $for->meta->find_attribute_by_name($_) } (
109 my $reader = $attr->get_read_method;
111 $classes{ $attr->init_arg }
112 = _make_new_class( $for->$reader(), $roles->{$key} );
115 my $new_meta = $new_metaclass->reinitialize( $for, %classes );
120 sub apply_base_class_roles {
123 my $for = $args{for} || $args{for_class};
125 my $meta = Class::MOP::class_of($for);
127 my $new_base = _make_new_class(
130 [ $meta->superclasses() ],
133 $meta->superclasses($new_base)
134 if $new_base ne $meta->name();
137 sub _make_new_class {
138 my $existing_class = shift;
140 my $superclasses = shift || [$existing_class];
142 return $existing_class unless $roles;
144 my $meta = Class::MOP::Class->initialize($existing_class);
146 return $existing_class
147 if $meta->can('does_role') && all { $meta->does_role($_) }
148 grep { !ref $_ } @{$roles};
150 return Moose::Meta::Class->create_anon_class(
151 superclasses => $superclasses,
163 Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
167 package MyApp::Moose;
171 use Moose::Util::MetaRole;
173 use MyApp::Role::Meta::Class;
174 use MyApp::Role::Meta::Method::Constructor;
175 use MyApp::Role::Object;
177 Moose::Exporter->setup_import_methods( also => 'Moose' );
183 Moose->init_meta(%args);
185 Moose::Util::MetaRole::apply_metaroles(
186 for => $args{for_class},
188 class => => ['MyApp::Role::Meta::Class'],
189 constructor => ['MyApp::Role::Meta::Method::Constructor'],
193 Moose::Util::MetaRole::apply_base_class_roles(
194 for => $args{for_class},
195 roles => ['MyApp::Role::Object'],
198 return $args{for_class}->meta();
203 This utility module is designed to help authors of Moose extensions
204 write extensions that are able to cooperate with other Moose
205 extensions. To do this, you must write your extensions as roles, which
206 can then be dynamically applied to the caller's metaclasses.
208 This module makes sure to preserve any existing superclasses and roles
209 already set for the meta objects, which means that any number of
210 extensions can apply roles in any order.
214 B<It is very important that you only call this module's functions when
215 your module is imported by the caller>. The process of applying roles
216 to the metaclass reinitializes the metaclass object, which wipes out
217 any existing attributes already defined. However, as long as you do
218 this when your module is imported, the caller should not have any
219 attributes defined yet.
221 The easiest way to ensure that this happens is to use
222 L<Moose::Exporter>, which can generate the appropriate C<init_meta>
223 method for you, and make sure it is called when imported.
227 This module provides two functions.
229 =head2 apply_metaroles( ... )
231 This function will apply roles to one or more metaclasses for the specified
232 class. It will return a new metaclass object for the class or role passed in
235 It accepts the following parameters:
241 This specifies the class or for which to alter the meta classes. This can be a
242 package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
243 L<Moose::Meta::Role>).
245 =item * class_metaroles => \%roles
247 This is a hash reference specifying which metaroles will be applied to the
248 class metaclass and its contained metaclasses and helper classes.
250 Each key should in turn point to an array reference of role names.
252 It accepts the following keys:
274 =item * role_metaroles => \%roles
276 This is a hash reference specifying which metaroles will be applied to the
277 role metaclass and its contained metaclasses and helper classes.
279 It accepts the following keys:
289 =item required_method
291 =item conflicting_method
293 =item application_to_class
295 =item application_to_role
297 =item application_to_instance
299 =item application_role_summation
305 =head2 apply_base_class_roles( for => $class, roles => \@roles )
307 This function will apply the specified roles to the object's base class.
311 See L<Moose/BUGS> for details on reporting bugs.
315 Dave Rolsky E<lt>autarch@urth.orgE<gt>
317 =head1 COPYRIGHT AND LICENSE
319 Copyright 2009 by Infinity Interactive, Inc.
321 L<http://www.iinteractive.com>
323 This library is free software; you can redistribute it and/or modify
324 it under the same terms as Perl itself.