X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=26174752f316eebb4181669ad808bb7bb60938e5;hb=8450b0017b64d1fc54baa1d3d301b9bdfab1494e;hp=b37b8c95044c10703c04d53cedec3a5219d4dc9e;hpb=ebff30043a7d359f6e81867d6b77d50457345fa2;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index b37b8c9..2617475 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -348,6 +348,83 @@ sub _base_metaclasses { ); } +sub _can_fix_metaclass_incompatibility { + my $self = shift; + return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_); + return $self->SUPER::_can_fix_metaclass_incompatibility(@_); +} + +sub _can_fix_metaclass_incompatibility_by_role_reconciliation { + my $self = shift; + my ($super_meta) = @_; + + return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta); + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + next unless defined $self->$metaclass_type; + return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta); + } + + return; +} + +sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { + my $self = shift; + my ($super_meta) = @_; + + my $super_meta_name = $super_meta->_real_ref_name; + + return $self->_classes_differ_by_roles_only( + blessed($self), + $super_meta_name, + 'Moose::Meta::Class', + ); +} + +sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { + my $self = shift; + my ($metaclass_type, $super_meta) = @_; + + my $class_specific_meta_name = $self->$metaclass_type; + return unless $super_meta->can($metaclass_type); + my $super_specific_meta_name = $super_meta->$metaclass_type; + my %metaclasses = $self->_base_metaclasses; + + 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_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; +} + sub _find_common_base { my $self = shift; my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; @@ -432,122 +509,6 @@ sub _is_role_only_subclass { return 1; } -sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; - - my $super_meta_name = $super_meta->_real_ref_name; - - return $self->_classes_differ_by_roles_only( - blessed($self), - $super_meta_name, - 'Moose::Meta::Class', - ); -} - -sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($metaclass_type, $super_meta) = @_; - - my $class_specific_meta_name = $self->$metaclass_type; - return unless $super_meta->can($metaclass_type); - my $super_specific_meta_name = $super_meta->$metaclass_type; - my %metaclasses = $self->_base_metaclasses; - - 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_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; -} - -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_with_inheritance') - ? $super_meta_name->meta->calculate_all_roles_with_inheritance - : (); - 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) { - push @differences, $role_meta - unless any { $_->name eq $role_meta->name } @super_role_metas; - } - return @differences; -} - -sub _reconcile_roles_for_metaclass { - my $self = shift; - my ($class_meta_name, $super_meta_name) = @_; - - my @role_differences = $self->_role_differences( - $class_meta_name, $super_meta_name, - ); - - # handle the case where we need to fix compatibility between a class and - # its parent, but all roles in the class are already also done by the - # parent - # see t/050/054.t - return Class::MOP::class_of($super_meta_name) - unless @role_differences; - - return Moose::Meta::Class->create_anon_class( - superclasses => [$super_meta_name], - roles => [map { $_->name } @role_differences], - cache => 1, - ); -} - -sub _can_fix_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; - - return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta); - - my %base_metaclass = $self->_base_metaclasses; - for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; - return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta); - } - - return; -} - -sub _can_fix_metaclass_incompatibility { - my $self = shift; - return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_); - return $self->SUPER::_can_fix_metaclass_incompatibility(@_); -} - sub _fix_class_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; @@ -560,12 +521,12 @@ sub _fix_class_metaclass_incompatibility { . $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( + my $class_meta_subclass_meta_name = $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 ); + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); } } @@ -581,16 +542,54 @@ sub _fix_single_metaclass_incompatibility { . $self->name . " because it is not pristine."; my $super_meta_name = $super_meta->_real_ref_name; - my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); + my $class_specific_meta_subclass_meta_name = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); my $new_self = $super_meta->reinitialize( $self->name, - $metaclass_type => $class_specific_meta_subclass_meta->name, + $metaclass_type => $class_specific_meta_subclass_meta_name, ); $self->_replace_self( $new_self, $super_meta_name ); } } +sub _reconcile_roles_for_metaclass { + my $self = shift; + my ($class_meta_name, $super_meta_name) = @_; + + my @role_differences = $self->_role_differences( + $class_meta_name, $super_meta_name, + ); + + # handle the case where we need to fix compatibility between a class and + # its parent, but all roles in the class are already also done by the + # parent + # see t/050/054.t + return $super_meta_name + unless @role_differences; + + return Moose::Meta::Class->create_anon_class( + superclasses => [$super_meta_name], + roles => [map { $_->name } @role_differences], + cache => 1, + )->name; +} + +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_with_inheritance') + ? $super_meta_name->meta->calculate_all_roles_with_inheritance + : (); + 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) { + push @differences, $role_meta + unless any { $_->name eq $role_meta->name } @super_role_metas; + } + return @differences; +} sub _replace_self { my $self = shift; @@ -606,6 +605,22 @@ sub _replace_self { Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class; } +sub _get_compatible_single_metaclass { + my $self = shift; + + return $self->SUPER::_get_compatible_single_metaclass(@_) + || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_); +} + +sub _get_compatible_single_metaclass_by_role_reconciliation { + my $self = shift; + my ($single_meta_name) = @_; + + my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name); + + return $self->_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name); +} + sub _process_attribute { my ( $self, $name, @args ) = @_;