Commit | Line | Data |
231be3be |
1 | package Moose::Util::MetaRole; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use List::MoreUtils qw( all ); |
7 | |
8 | sub apply_metaclass_roles { |
9 | my %options = @_; |
10 | |
11 | my $for = $options{for_class}; |
12 | |
13 | my $meta = _make_new_metaclass( $for, \%options ); |
14 | |
15 | for my $tor_class ( grep { $options{ $_ . '_roles' } } |
16 | qw( constructor_class destructor_class ) ) { |
17 | |
18 | my $class = _make_new_class( |
19 | $meta->$tor_class(), |
20 | $options{ $tor_class . '_roles' } |
21 | ); |
22 | |
23 | $meta->$tor_class($class); |
24 | } |
25 | |
26 | return $meta; |
27 | } |
28 | |
29 | sub _make_new_metaclass { |
30 | my $for = shift; |
31 | my $options = shift; |
32 | |
33 | return $for->meta() |
34 | unless grep { exists $options->{ $_ . '_roles' } } |
35 | qw( |
36 | metaclass |
37 | attribute_metaclass |
38 | method_metaclass |
39 | instance_metaclass |
40 | ); |
41 | |
42 | my $new_metaclass |
43 | = _make_new_class( ref $for->meta(), $options->{metaclass_roles} ); |
44 | |
45 | my $old_meta = $for->meta(); |
46 | |
47 | Class::MOP::remove_metaclass_by_name($for); |
48 | |
49 | my %classes = map { |
50 | $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } ) |
51 | } qw( |
52 | attribute_metaclass |
53 | method_metaclass |
54 | instance_metaclass |
55 | ); |
56 | |
57 | return $new_metaclass->reinitialize( $for, %classes ); |
58 | } |
59 | |
60 | sub apply_base_class_roles { |
61 | my %options = @_; |
62 | |
63 | my $for = $options{for_class}; |
64 | |
65 | my $meta = $for->meta(); |
66 | |
67 | my $new_base = _make_new_class( |
68 | $for, |
69 | $options{roles}, |
70 | [ $meta->superclasses() ], |
71 | ); |
72 | |
73 | $meta->superclasses($new_base) |
74 | if $new_base ne $meta->name(); |
75 | } |
76 | |
77 | sub _make_new_class { |
78 | my $existing_class = shift; |
79 | my $roles = shift; |
80 | my $superclasses = shift || [$existing_class]; |
81 | |
82 | return $existing_class unless $roles; |
83 | |
84 | my $meta = $existing_class->meta(); |
85 | |
86 | return $existing_class |
87 | if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles}; |
88 | |
89 | return Moose::Meta::Class->create_anon_class( |
90 | superclasses => $superclasses, |
91 | roles => $roles, |
92 | cache => 1, |
93 | )->name(); |
94 | } |
95 | |
96 | 1; |
c59bc009 |
97 | |
98 | __END__ |
99 | |
100 | =head1 NAME |
101 | |
102 | Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class |
103 | |
104 | =head1 SYNOPSIS |
105 | |
106 | package MyApp::Moose; |
107 | |
108 | use strict; |
109 | use warnings; |
110 | |
111 | use Moose (); |
112 | use Moose::Exporter; |
113 | use Moose::Util::Meta::Role; |
114 | |
115 | use MyApp::Role::Meta::Class; |
116 | use MyApp::Role::Meta::Method::Constructor; |
117 | use MyApp::Role::Object; |
118 | |
119 | Moose::Exporter->setup_import_methods( also => 'Moose' ); |
120 | |
121 | sub init_meta { |
122 | shift; |
123 | my %options = @_; |
124 | |
125 | Moose->init_meta(%options); |
126 | |
127 | Moose::Util::MetaRole::apply_metaclass_roles( |
128 | for_class => $options{for_class}, |
129 | metaclass_roles => ['MyApp::Role::Meta::Class'], |
130 | constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'], |
131 | ); |
132 | |
133 | Moose::Util::MetaRole::apply_base_class_roles( |
134 | for_class => $options{for_class}, |
135 | roles => ['MyApp::Role::Object'], |
136 | ); |
137 | |
138 | return $options{for_class}->meta(); |
139 | } |
140 | |
141 | =head1 DESCRIPTION |
142 | |
143 | This utility module is designed to help authors of Moose extensions |
144 | write extensions that are able to cooperate with other Moose |
145 | extensions. To do this, you must write your extensions as roles, which |
146 | can then be dynamically applyied to the caller's metaclasses. |
147 | |
148 | This module makes sure to preserve any existing superclasses and roles |
149 | already set for the meta objects, which means that any number of |
150 | extensions can apply roles in any order. |
151 | |
152 | =head1 USAGE |
153 | |
154 | B<It is very important that you only call this module's functions when |
155 | your module is imported by the caller>. The process of applying roles |
156 | to the metaclass reinitializes the metaclass object, which wipes out |
157 | any existing attributes already defined. However, as long as you do |
158 | this when your module is imported, the caller should not have any |
159 | attributes defined yet. |
160 | |
161 | The easiest way to ensure that this happens is to use |
162 | L<Moose::Exporter> and provide an C<init_meta> method that will be |
163 | called when imported. |
164 | |
165 | =head1 FUNCTIONS |
166 | |
167 | This module provides two functions. |
168 | |
169 | =head2 apply_metaclass_roles( ... ) |
170 | |
171 | This function will apply roles to one or more metaclasses for the |
172 | specified class. It accepts the following parameters: |
173 | |
174 | =over 4 |
175 | |
176 | =item * for_class => $name |
177 | |
178 | This specifies the class for which to alter the meta classes. |
179 | |
180 | =item * metaclass_roles => \@roles |
181 | |
182 | =item * attribute_metaclass_roles => \@roles |
183 | |
184 | =item * method_metaclass_roles => \@roles |
185 | |
186 | =item * instance_metaclass_roles => \@roles |
187 | |
188 | =item * constructor_class_roles => \@roles |
189 | |
190 | =item * destructor_class_roles => \@roles |
191 | |
192 | These parameter all specify one or more roles to be applied to the |
193 | specified metaclass. You can pass any or all of these parameters at |
194 | once. |
195 | |
196 | =back |
197 | |
198 | =head2 apply_base_class_roles( for_class => $class, roles => \@roles ) |
199 | |
200 | This function will apply the specified roles to the object's base class. |
201 | |
202 | =head1 AUTHOR |
203 | |
204 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
205 | |
206 | =head1 COPYRIGHT AND LICENSE |
207 | |
208 | Copyright 2008 by Infinity Interactive, Inc. |
209 | |
210 | L<http://www.iinteractive.com> |
211 | |
212 | This library is free software; you can redistribute it and/or modify |
213 | it under the same terms as Perl itself. |
214 | |
215 | =cut |