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