X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=1b8b875d96e927461f70ac2b8a6e582179458a5f;hb=e462f6f3d260687b8f7372b112a50c5c2a2c431c;hp=1eec1a6a2d8905ca2f18c879e548f9e97524122a;hpb=dd3ac8f94d9b58bde82976f329e24a41dbd86736;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 1eec1a6..1b8b875 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -6,13 +6,13 @@ use warnings; use Class::MOP; -use Carp (); +use Carp qw( confess ); use Data::OptList; use List::Util qw( first ); use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '1.04'; +our $VERSION = '1.05'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -200,6 +200,16 @@ sub calculate_all_roles { grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; } +sub calculate_all_roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('calculate_all_roles') + ? Class::MOP::class_of($_)->calculate_all_roles + : () } + $self->linearized_isa; +} + sub does_role { my ($self, $role_name) = @_; @@ -354,10 +364,10 @@ sub _base_metaclasses { sub _find_common_base { my $self = shift; my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; - return unless defined($meta1) && defined($meta2); + return unless defined $meta1 && defined $meta2; # FIXME? This doesn't account for multiple inheritance (not sure - # if it needs to though). For example, is somewhere in $meta1's + # if it needs to though). For example, if somewhere in $meta1's # history it inherits from both ClassA and ClassB, and $meta2 # inherits from ClassB & ClassA, does it matter? And what crazy # fool would do that anyway? @@ -391,16 +401,32 @@ sub _is_role_only_subclass { my ($parent_name) = @parent_names; my $parent_meta = Class::MOP::Class->initialize($parent_name); + my @roles = $meta->can('calculate_all_roles_with_inheritance') + ? $meta->calculate_all_roles_with_inheritance + : (); + # loop over all methods that are a part of the current class # (not inherited) for my $method (map { $meta->get_method($_) } $meta->get_method_list) { # always ignore meta next if $method->name eq 'meta'; # we'll deal with attributes below - next if $method->isa('Class::MOP::Method::Accessor'); + next if $method->can('associated_attribute'); # if the method comes from a role we consumed, ignore it next if $meta->can('does_role') && $meta->does_role($method->original_package_name); + # FIXME - this really isn't right. Just because a modifier is + # defined in a role doesn't mean it isn't _also_ defined in the + # subclass. + next if $method->isa('Class::MOP::Method::Wrapped') + && ( + (!scalar($method->around_modifiers) + || any { $_->has_around_method_modifiers($method->name) } @roles) + && (!scalar($method->before_modifiers) + || any { $_->has_before_method_modifiers($method->name) } @roles) + && (!scalar($method->after_modifiers) + || any { $_->has_after_method_modifiers($method->name) } @roles) + ); return 0; } @@ -411,11 +437,7 @@ sub _is_role_only_subclass { # defined in a role doesn't mean it isn't _also_ defined in the # subclass. for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { - next if any { $_->has_attribute($attr->name) } - map { $_->meta->can('calculate_all_roles') - ? $_->meta->calculate_all_roles - : () } - $meta->linearized_isa; + next if any { $_->has_attribute($attr->name) } @roles; return 0; } @@ -427,20 +449,13 @@ sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { my $self = shift; my ($super_meta) = @_; - my $common_base_name = $self->_find_common_base(blessed($self), blessed($super_meta)); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base_name); - return unless $common_base_name->isa('Moose::Meta::Class'); - - my @super_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($super_meta), $common_base_name); - my @class_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($self), $common_base_name); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@super_meta_name_ancestor_names, - @class_meta_name_ancestor_names); + my $super_meta_name = $super_meta->_real_ref_name; - return 1; + return $self->_classes_differ_by_roles_only( + blessed($self), + $super_meta_name, + 'Moose::Meta::Class', + ); } sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { @@ -452,18 +467,36 @@ sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { my $super_specific_meta_name = $super_meta->$metaclass_type; my %metaclasses = $self->_base_metaclasses; - my $common_base_name = $self->_find_common_base($class_specific_meta_name, $super_specific_meta_name); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base_name); - return unless $common_base_name->isa($metaclasses{$metaclass_type}); + return $self->_classes_differ_by_roles_only( + $class_specific_meta_name, + $super_specific_meta_name, + $metaclasses{$metaclass_type}, + ); +} + +sub _classes_differ_by_roles_only { + my $self = shift; + my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_; + + my $common_base_name + = $self->_find_common_base( $self_meta_name, $super_meta_name ); + + # If they're not both moose metaclasses, and the cmop fixing couldn't do + # anything, there's nothing more we can do. The $expected_ancestor should + # always be a Moose metaclass name like Moose::Meta::Class or + # Moose::Meta::Attribute. + return unless defined $common_base_name; + return unless $common_base_name->isa($expected_ancestor); - my @super_specific_meta_name_ancestor_names = $self->_get_ancestors_until($super_specific_meta_name, $common_base_name); - my @class_specific_meta_name_ancestor_names = $self->_get_ancestors_until($class_specific_meta_name, $common_base_name); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@super_specific_meta_name_ancestor_names, - @class_specific_meta_name_ancestor_names); + my @super_meta_name_ancestor_names + = $self->_get_ancestors_until( $super_meta_name, $common_base_name ); + my @class_meta_name_ancestor_names + = $self->_get_ancestors_until( $self_meta_name, $common_base_name ); + + return + unless all { $self->_is_role_only_subclass($_) } + @super_meta_name_ancestor_names, + @class_meta_name_ancestor_names; return 1; } @@ -471,11 +504,11 @@ sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { sub _role_differences { my $self = shift; my ($class_meta_name, $super_meta_name) = @_; - my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles') - ? $super_meta_name->meta->calculate_all_roles + my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance') + ? $super_meta_name->meta->calculate_all_roles_with_inheritance : (); - my @role_metas = $class_meta_name->meta->can('calculate_all_roles') - ? $class_meta_name->meta->calculate_all_roles + my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance') + ? $class_meta_name->meta->calculate_all_roles_with_inheritance : (); my @differences; for my $role_meta (@role_metas) { @@ -492,7 +525,7 @@ sub _reconcile_roles_for_metaclass { my @role_differences = $self->_role_differences( $class_meta_name, $super_meta_name, ); - return $self->create_anon_class( + return Moose::Meta::Class->create_anon_class( superclasses => [$super_meta_name], roles => \@role_differences, cache => 1, @@ -527,11 +560,17 @@ sub _fix_class_metaclass_incompatibility { $self->SUPER::_fix_class_metaclass_incompatibility(@_); if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) { - my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), blessed($super_meta)); - # XXX: this doesn't work! we're reblessing $self into a subclass of - # $super_meta, not of itself... probably do need to just go ahead and - # reinitialize things here - $class_meta_subclass_meta->rebless_instance($self); + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + my $super_meta_name = $super_meta->_real_ref_name; + my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); + my $new_self = $class_meta_subclass_meta->name->reinitialize( + $self->name, + ); + + $self->_replace_self( $new_self, $class_meta_subclass_meta->name ); } } @@ -542,12 +581,35 @@ sub _fix_single_metaclass_incompatibility { $self->SUPER::_fix_single_metaclass_incompatibility(@_); if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) { - my %metaclasses = $self->_base_metaclasses; + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); - $self->$metaclass_type($class_specific_meta_subclass_meta->name); + my $new_self = $super_meta->reinitialize( + $self->name, + $metaclass_type => $class_specific_meta_subclass_meta->name, + ); + + $self->_replace_self( $new_self, blessed($super_meta) ); } } + +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; + + %$self = %$new_self; + bless $self, $new_class; + + # We need to replace the cached metaclass instance or else when it goes + # out of scope Class::MOP::Class destroy's the namespace for the + # metaclass's class, causing much havoc. + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class; +} + sub _process_attribute { my ( $self, $name, @args ) = @_; @@ -727,6 +789,11 @@ This adds an C method modifier to the package. This will return a unique array of C instances which are attached to this class. +=item B<< $metaclass->calculate_all_roles_with_inheritance >> + +This will return a unique array of C instances +which are attached to this class, and each of this class's ancestors. + =item B<< $metaclass->add_role($role) >> This takes a L object, and adds it to the class's