X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FRole.pm;h=c35f7cd08a79e9079555669663394f22b7c25173;hb=c350159ff34283e00527a23b36177482962d8d82;hp=3eb9ef334270ef1e6ef07755367d78f3bd44b1da;hpb=d79e62fdf0519b8a6d25b1520463b9714997ea5f;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 3eb9ef3..c35f7cd 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -7,20 +7,18 @@ use metaclass; use Carp 'confess'; use Scalar::Util 'blessed'; +use B 'svref_2object'; + +our $VERSION = '0.07'; +our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Class; +use Moose::Meta::Role::Method; -our $VERSION = '0.03'; +use base 'Class::MOP::Module'; ## Attributes -## the meta for the role package - -__PACKAGE__->meta->add_attribute('_role_meta' => ( - reader => '_role_meta', - init_arg => ':role_meta' -)); - ## roles __PACKAGE__->meta->add_attribute('roles' => ( @@ -73,17 +71,7 @@ __PACKAGE__->meta->add_attribute('override_method_modifiers' => ( ## Methods -sub new { - my $class = shift; - my %options = @_; - $options{':role_meta'} = Moose::Meta::Class->initialize( - $options{role_name}, - ':method_metaclass' => 'Moose::Meta::Role::Method' - ) unless defined $options{':role_meta'} && - $options{':role_meta'}->isa('Moose::Meta::Class'); - my $self = $class->meta->new_object(%options); - return $self; -} +sub method_metaclass { 'Moose::Meta::Role::Method' } ## subroles @@ -94,6 +82,12 @@ sub add_role { push @{$self->get_roles} => $role; } +sub calculate_all_roles { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles }; +} + sub does_role { my ($self, $role_name) = @_; (defined $role_name) @@ -131,6 +125,11 @@ sub add_required_methods { $self->get_required_methods_map->{$_} = undef foreach @methods; } +sub remove_required_methods { + my ($self, @methods) = @_; + delete $self->get_required_methods_map->{$_} foreach @methods; +} + sub get_required_method_list { my ($self) = @_; keys %{$self->get_required_methods_map}; @@ -144,45 +143,53 @@ sub requires_method { sub _clean_up_required_methods { my $self = shift; foreach my $method ($self->get_required_method_list) { - delete $self->get_required_methods_map->{$method} + $self->remove_required_methods($method) if $self->has_method($method); } } ## methods -# NOTE: -# we delegate to some role_meta methods for convience here -# the Moose::Meta::Role is meant to be a read-only interface -# to the underlying role package, if you want to manipulate -# that, just use ->role_meta - -sub name { (shift)->_role_meta->name } -sub version { (shift)->_role_meta->version } +# FIXME: +# this is an UGLY hack +sub get_method_map { + my $self = shift; + $self->{'%!methods'} ||= {}; + $self->Moose::Meta::Class::get_method_map() +} -sub get_method { (shift)->_role_meta->get_method(@_) } -sub has_method { (shift)->_role_meta->has_method(@_) } -sub alias_method { (shift)->_role_meta->alias_method(@_) } -sub get_method_list { - my ($self) = @_; - grep { - # NOTE: - # this is a kludge for now,... these functions - # should not be showing up in the list at all, - # but they do, so we need to switch Moose::Role - # and Moose to use Sub::Exporter to prevent this - !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/ - } $self->_role_meta->get_method_list; +# FIXME: +# Yes, this is a really really UGLY hack +# but it works, and until I can figure +# out a better way, this is gonna be it. + +sub get_method { (shift)->Moose::Meta::Class::get_method(@_) } +sub has_method { (shift)->Moose::Meta::Class::has_method(@_) } +sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) } +sub get_method_list { + grep { + !/^meta$/ + } (shift)->Moose::Meta::Class::get_method_list(@_) } +sub find_method_by_name { (shift)->has_method(@_) } + # ... however the items in statis (attributes & method modifiers) # can be removed and added to through this API # attributes sub add_attribute { - my ($self, $name, %attr_desc) = @_; - $self->get_attribute_map->{$name} = \%attr_desc; + my $self = shift; + my $name = shift; + my $attr_desc; + if (scalar @_ == 1 && ref($_[0]) eq 'HASH') { + $attr_desc = $_[0]; + } + else { + $attr_desc = { @_ }; + } + $self->get_attribute_map->{$name} = $attr_desc; } sub has_attribute { @@ -217,11 +224,22 @@ sub _add_method_modifier { my $accessor = "get_${modifier_type}_method_modifiers_map"; $self->$accessor->{$method_name} = [] unless exists $self->$accessor->{$method_name}; - push @{$self->$accessor->{$method_name}} => $method; + my $modifiers = $self->$accessor->{$method_name}; + # NOTE: + # check to see that we aren't adding the + # same code twice. We err in favor of the + # first on here, this may not be as expected + foreach my $modifier (@{$modifiers}) { + return if $modifier == $method; + } + push @{$modifiers} => $method; } sub add_override_method_modifier { my ($self, $method_name, $method) = @_; + (!$self->has_method($method_name)) + || confess "Cannot add an override of method '$method_name' " . + "because there is a local version of '$method_name'"; $self->get_override_method_modifiers_map->{$method_name} = $method; } @@ -265,31 +283,26 @@ sub get_method_modifier_list { ## applying a role to a class ... -sub apply { +sub _check_excluded_roles { my ($self, $other) = @_; - if ($other->excludes_role($self->name)) { confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'"; } - -# warn "... Checking " . $self->name . " for excluded methods"; foreach my $excluded_role_name ($self->get_excluded_roles_list) { -# warn "... Checking if '$excluded_role_name' is done by " . $other->name . " for " . $self->name; - if ($other->does_role($excluded_role_name)) { # || $self->does_role($excluded_role_name) + if ($other->does_role($excluded_role_name)) { confess "The class " . $other->name . " does the excluded role '$excluded_role_name'"; } else { if ($other->isa('Moose::Meta::Role')) { -# warn ">>> The role " . $other->name . " does not do the excluded role '$excluded_role_name', so we are adding it in"; $other->add_excluded_roles($excluded_role_name); } - else { -# warn ">>> The class " . $other->name . " does not do the excluded role '$excluded_role_name', so we can just go about our business"; - } + # else -> ignore it :) } } - - +} + +sub _check_required_methods { + my ($self, $other) = @_; # NOTE: # we might need to move this down below the # the attributes so that we can require any @@ -297,7 +310,8 @@ sub apply { # that maybe those are somehow exempt from # the require methods stuff. foreach my $required_method_name ($self->get_required_method_list) { - unless ($other->has_method($required_method_name)) { + + unless ($other->find_method_by_name($required_method_name)) { if ($other->isa('Moose::Meta::Role')) { $other->add_required_methods($required_method_name); } @@ -306,21 +320,40 @@ sub apply { "to be implemented by '" . $other->name . "'"; } } - } - + else { + # NOTE: + # we need to make sure that the method is + # not a method modifier, because those do + # not satisfy the requirements ... + my $method = $other->get_method($required_method_name); + # check if it is an override or a generated accessor .. + (!$method->isa('Moose::Meta::Method::Overriden') && + !$method->isa('Class::MOP::Method::Accessor')) + || confess "'" . $self->name . "' requires the method '$required_method_name' " . + "to be implemented by '" . $other->name . "', the method is only a method modifier"; + # before/after/around methods are a little trickier + # since we wrap the original local method (if applicable) + # so we need to check if the original wrapped method is + # from the same package, and not a wrap of the super method + if ($method->isa('Class::MOP::Method::Wrapped')) { + ($method->get_original_method->package_name eq $other->name) + || confess "'" . $self->name . "' requires the method '$required_method_name' " . + "to be implemented by '" . $other->name . "', the method is only a method modifier"; + } + } + } +} + +sub _apply_attributes { + my ($self, $other) = @_; foreach my $attribute_name ($self->get_attribute_list) { # it if it has one already - if ($other->has_attribute($attribute_name)) { + if ($other->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) { # see if we are being composed # into a role or not - if ($other->isa('Moose::Meta::Role')) { - - # FIXME: - # it is possible for these attributes - # to actually both be from the same - # origin (some common ancestor role) - # so we need to find a way to check this - + if ($other->isa('Moose::Meta::Role')) { # all attribute conflicts between roles # result in an immediate fatal error confess "Role '" . $self->name . "' has encountered an attribute conflict " . @@ -334,17 +367,31 @@ sub apply { } } else { - # add it, although it could be overriden - $other->add_attribute( - $attribute_name, - %{$self->get_attribute($attribute_name)} - ); + # NOTE: + # this is kinda ugly ... + if ($other->isa('Moose::Meta::Class')) { + $other->_process_attribute( + $attribute_name, + %{$self->get_attribute($attribute_name)} + ); + } + else { + $other->add_attribute( + $attribute_name, + $self->get_attribute($attribute_name) + ); + } } - } - + } +} + +sub _apply_methods { + my ($self, $other) = @_; foreach my $method_name ($self->get_method_list) { # it if it has one already - if ($other->has_method($method_name)) { + if ($other->has_method($method_name) && + # and if they are not the same thing ... + $other->get_method($method_name)->body != $self->get_method($method_name)->body) { # see if we are composing into a role if ($other->isa('Moose::Meta::Role')) { # method conflicts between roles result @@ -358,8 +405,8 @@ sub apply { # is probably fairly safe to assume that # anon classes will only be used internally # or by people who know what they are doing - $other->_role_meta->remove_method($method_name) - if $other->_role_meta->name =~ /__ANON__/; + $other->Moose::Meta::Class::remove_method($method_name) + if $other->name =~ /__COMPOSITE_ROLE_SANDBOX__/; } else { next; @@ -372,8 +419,11 @@ sub apply { $self->get_method($method_name) ); } - } - + } +} + +sub _apply_override_method_modifiers { + my ($self, $other) = @_; foreach my $method_name ($self->get_method_modifier_list('override')) { # it if it has one already then ... if ($other->has_method($method_name)) { @@ -399,60 +449,99 @@ sub apply { # if we are a role, we need to make sure # we dont have a conflict with the role # we are composing into - if ($other->has_override_method_modifier($method_name)) { + if ($other->has_override_method_modifier($method_name) && + $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) { confess "Role '" . $self->name . "' has encountered an 'override' method conflict " . "during composition (Two 'override' methods of the same name encountered). " . "This is fatal error."; } - else { + else { + # if there is no conflict, + # just add it to the role $other->add_override_method_modifier( - $method_name, - $self->get_override_method_modifier($method_name), - $self->name + $method_name, + $self->get_override_method_modifier($method_name) ); } } else { + # if this is not a role, then we need to + # find the original package of the method + # so that we can tell the class were to + # find the right super() method + my $method = $self->get_override_method_modifier($method_name); + my $package = svref_2object($method)->GV->STASH->NAME; # if it is a class, we just add it - $other->add_override_method_modifier( - $method_name, - $self->get_override_method_modifier($method_name), - $self->name - ); + $other->add_override_method_modifier($method_name, $method, $package); } } } - - foreach my $method_name ($self->get_method_modifier_list('before')) { - $other->add_before_method_modifier( +} + +sub _apply_method_modifiers { + my ($self, $modifier_type, $other) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($self->get_method_modifier_list($modifier_type)) { + $other->$add( $method_name, $_ - ) foreach $self->get_before_method_modifiers($method_name); + ) foreach $self->$get($method_name); } +} + +sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) } +sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) } +sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) } + +my $anon_counter = 0; + +sub apply { + my ($self, $other) = @_; - foreach my $method_name ($self->get_method_modifier_list('after')) { - $other->add_after_method_modifier( - $method_name, - $_ - ) foreach $self->get_after_method_modifiers($method_name); - } + unless ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) { - foreach my $method_name ($self->get_method_modifier_list('around')) { - $other->add_around_method_modifier( - $method_name, - $_ - ) foreach $self->get_around_method_modifiers($method_name); - } + # Runtime Role mixins + + # FIXME: + # We really should do this better, and + # cache the results of our efforts so + # that we don't need to repeat them. + + my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++; + eval "package " . $pkg_name . "; our \$VERSION = '0.00';"; + die $@ if $@; + + my $object = $other; + + $other = Moose::Meta::Class->initialize($pkg_name); + $other->superclasses(blessed($object)); + + bless $object => $pkg_name; + } + $self->_check_excluded_roles($other); + $self->_check_required_methods($other); + + $self->_apply_attributes($other); + $self->_apply_methods($other); + + $self->_apply_override_method_modifiers($other); + $self->_apply_before_method_modifiers($other); + $self->_apply_around_method_modifiers($other); + $self->_apply_after_method_modifiers($other); + $other->add_role($self); } sub combine { my ($class, @roles) = @_; - my $combined = $class->new( - ':role_meta' => Moose::Meta::Class->create_anon_class() - ); + my $pkg_name = __PACKAGE__ . "::__COMPOSITE_ROLE_SANDBOX__::" . $anon_counter++; + eval "package " . $pkg_name . "; our \$VERSION = '0.00';"; + die $@ if $@; + + my $combined = $class->initialize($pkg_name); foreach my $role (@roles) { $role->apply($combined); @@ -463,15 +552,6 @@ sub combine { return $combined; } -package Moose::Meta::Role::Method; - -use strict; -use warnings; - -our $VERSION = '0.01'; - -use base 'Class::MOP::Method'; - 1; __END__ @@ -484,9 +564,9 @@ Moose::Meta::Role - The Moose Role metaclass =head1 DESCRIPTION -Moose's Roles are being actively developed, please see L -for more information. For the most part, this has no user-serviceable -parts inside. It's API is still subject to some change (although +Please see L for more information about roles. +For the most part, this has no user-serviceable parts inside +this module. It's API is still subject to some change (although probably not that much really). =head1 METHODS @@ -533,10 +613,16 @@ probably not that much really). =item B +=item B + =back =over 4 +=item B + +=item B + =item B =item B @@ -545,6 +631,8 @@ probably not that much really). =item B +=item B + =back =over 4 @@ -567,6 +655,8 @@ probably not that much really). =item B +=item B + =item B =item B @@ -637,11 +727,11 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut