2 package Moose::Meta::Role;
9 use Scalar::Util 'blessed';
10 use B 'svref_2object';
12 use Moose::Meta::Class;
14 our $VERSION = '0.04';
16 use base 'Class::MOP::Module';
22 __PACKAGE__->meta->add_attribute('roles' => (
23 reader => 'get_roles',
29 __PACKAGE__->meta->add_attribute('excluded_roles_map' => (
30 reader => 'get_excluded_roles_map',
36 __PACKAGE__->meta->add_attribute('attribute_map' => (
37 reader => 'get_attribute_map',
43 __PACKAGE__->meta->add_attribute('required_methods' => (
44 reader => 'get_required_methods_map',
50 sub method_metaclass { 'Moose::Meta::Role::Method' }
55 my ($self, $role) = @_;
56 (blessed($role) && $role->isa('Moose::Meta::Role'))
57 || confess "Roles must be instances of Moose::Meta::Role";
58 push @{$self->get_roles} => $role;
61 sub calculate_all_roles {
64 grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles };
68 my ($self, $role_name) = @_;
70 || confess "You must supply a role name to look for";
71 # if we are it,.. then return true
72 return 1 if $role_name eq $self->name;
73 # otherwise.. check our children
74 foreach my $role (@{$self->get_roles}) {
75 return 1 if $role->does_role($role_name);
82 sub add_excluded_roles {
83 my ($self, @excluded_role_names) = @_;
84 $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names;
87 sub get_excluded_roles_list {
89 keys %{$self->get_excluded_roles_map};
93 my ($self, $role_name) = @_;
94 exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0;
99 sub add_required_methods {
100 my ($self, @methods) = @_;
101 $self->get_required_methods_map->{$_} = undef foreach @methods;
104 sub remove_required_methods {
105 my ($self, @methods) = @_;
106 delete $self->get_required_methods_map->{$_} foreach @methods;
109 sub get_required_method_list {
111 keys %{$self->get_required_methods_map};
114 sub requires_method {
115 my ($self, $method_name) = @_;
116 exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
119 sub _clean_up_required_methods {
121 foreach my $method ($self->get_required_method_list) {
122 $self->remove_required_methods($method)
123 if $self->has_method($method);
129 sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
130 sub find_method_by_name { (shift)->Moose::Meta::Class::find_method_by_name(@_) }
131 sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
132 sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
133 sub get_method_list {
137 # this is a kludge for now,... these functions
138 # should not be showing up in the list at all,
139 # but they do, so we need to switch Moose::Role
140 # and Moose to use Sub::Exporter to prevent this
141 !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
142 } $self->Moose::Meta::Class::get_method_list;
145 # ... however the items in statis (attributes & method modifiers)
146 # can be removed and added to through this API
154 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
160 $self->get_attribute_map->{$name} = $attr_desc;
164 my ($self, $name) = @_;
165 exists $self->get_attribute_map->{$name} ? 1 : 0;
169 my ($self, $name) = @_;
170 $self->get_attribute_map->{$name}
173 sub remove_attribute {
174 my ($self, $name) = @_;
175 delete $self->get_attribute_map->{$name}
178 sub get_attribute_list {
180 keys %{$self->get_attribute_map};
184 ## applying a role to a class ...
186 sub _check_excluded_roles {
187 my ($self, $other) = @_;
188 if ($other->excludes_role($self->name)) {
189 confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
191 foreach my $excluded_role_name ($self->get_excluded_roles_list) {
192 if ($other->does_role($excluded_role_name)) {
193 confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
196 if ($other->isa('Moose::Meta::Role')) {
197 $other->add_excluded_roles($excluded_role_name);
199 # else -> ignore it :)
204 sub _check_required_methods {
205 my ($self, $other) = @_;
207 # we might need to move this down below the
208 # the attributes so that we can require any
209 # attribute accessors. However I am thinking
210 # that maybe those are somehow exempt from
211 # the require methods stuff.
212 foreach my $required_method_name ($self->get_required_method_list) {
214 unless ($other->find_method_by_name($required_method_name)) {
215 if ($other->isa('Moose::Meta::Role')) {
216 $other->add_required_methods($required_method_name);
219 confess "'" . $self->name . "' requires the method '$required_method_name' " .
220 "to be implemented by '" . $other->name . "'";
226 sub _apply_attributes {
227 my ($self, $other) = @_;
228 foreach my $attribute_name ($self->get_attribute_list) {
229 # it if it has one already
230 if ($other->has_attribute($attribute_name) &&
231 # make sure we haven't seen this one already too
232 $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
233 # see if we are being composed
235 if ($other->isa('Moose::Meta::Role')) {
236 # all attribute conflicts between roles
237 # result in an immediate fatal error
238 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
239 "during composition. This is fatal error and cannot be disambiguated.";
242 # but if this is a class, we
243 # can safely skip adding the
244 # attribute to the class
249 $other->add_attribute(
251 $self->get_attribute($attribute_name)
258 my ($self, $other) = @_;
259 foreach my $method_name ($self->get_method_list) {
260 # it if it has one already
261 if ($other->has_method($method_name) &&
262 # and if they are not the same thing ...
263 $other->get_method($method_name) != $self->get_method($method_name)) {
264 # see if we are composing into a role
265 if ($other->isa('Moose::Meta::Role')) {
266 # method conflicts between roles result
267 # in the method becoming a requirement
268 $other->add_required_methods($method_name);
270 # we have to remove the method from our
271 # role, if this is being called from combine()
272 # which means the meta is an anon class
273 # this *may* cause problems later, but it
274 # is probably fairly safe to assume that
275 # anon classes will only be used internally
276 # or by people who know what they are doing
277 $other->Moose::Meta::Class::remove_method($method_name)
278 if $other->name =~ /__ANON__/;
285 # add it, although it could be overriden
286 $other->alias_method(
288 $self->get_method($method_name)
295 my ($self, $other) = @_;
297 ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role'))
298 || confess "You must apply a role to a metaclass, not ($other)";
300 $self->_check_excluded_roles($other);
301 $self->_check_required_methods($other);
303 $self->_apply_attributes($other);
304 $self->_apply_methods($other);
306 $other->add_role($self);
309 my $anon_counter = 0;
312 my ($class, @roles) = @_;
314 my $pkg_name = __PACKAGE__ . "::__ANON__::" . $anon_counter++;
315 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
318 my $combined = $class->initialize($pkg_name);
320 foreach my $role (@roles) {
321 $role->apply($combined);
324 $combined->_clean_up_required_methods;
329 package Moose::Meta::Role::Method;
334 our $VERSION = '0.01';
336 use base 'Class::MOP::Method';
346 Moose::Meta::Role - The Moose Role metaclass
350 Moose's Roles are being actively developed, please see L<Moose::Role>
351 for more information. For the most part, this has no user-serviceable
352 parts inside. It's API is still subject to some change (although
353 probably not that much really).
391 =item B<add_excluded_roles>
393 =item B<excludes_role>
395 =item B<get_excluded_roles_list>
397 =item B<get_excluded_roles_map>
399 =item B<calculate_all_roles>
405 =item B<method_metaclass>
407 =item B<find_method_by_name>
413 =item B<alias_method>
415 =item B<get_method_list>
421 =item B<add_attribute>
423 =item B<has_attribute>
425 =item B<get_attribute>
427 =item B<get_attribute_list>
429 =item B<get_attribute_map>
431 =item B<remove_attribute>
437 =item B<add_required_methods>
439 =item B<remove_required_methods>
441 =item B<get_required_method_list>
443 =item B<get_required_methods_map>
445 =item B<requires_method>
451 All complex software has bugs lurking in it, and this module is no
452 exception. If you find a bug please either email me, or add the bug
457 Stevan Little E<lt>stevan@iinteractive.comE<gt>
459 =head1 COPYRIGHT AND LICENSE
461 Copyright 2006 by Infinity Interactive, Inc.
463 L<http://www.iinteractive.com>
465 This library is free software; you can redistribute it and/or modify
466 it under the same terms as Perl itself.