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