X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=a36ea37e536515a6976b0c3ef5087c2609232ac2;hb=ae7820b1b884344a7ee90d94b484ca46459eb7b1;hp=28713b0043ec86725fb6a6e6b495452c4bce51fb;hpb=f6df97aedcf7e635cfcc0ebcfe514fbc4ae6c6c1;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 28713b0..a36ea37 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.06';
 $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?
@@ -369,38 +379,54 @@ sub _find_common_base {
 
 sub _get_ancestors_until {
     my $self = shift;
-    my ($start, $until) = @_;
+    my ($start_name, $until_name) = @_;
 
-    my @ancestors;
-    for my $ancestor (Class::MOP::class_of($start)->linearized_isa) {
-        last if $ancestor eq $until;
-        push @ancestors, $ancestor;
+    my @ancestor_names;
+    for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
+        last if $ancestor_name eq $until_name;
+        push @ancestor_names, $ancestor_name;
     }
-    return @ancestors;
+    return @ancestor_names;
 }
 
 sub _is_role_only_subclass {
     my $self = shift;
-    my ($class) = @_;
-    my $meta = Class::MOP::Class->initialize($class);
-    my @parents = $meta->superclasses;
+    my ($meta_name) = @_;
+    my $meta = Class::MOP::Class->initialize($meta_name);
+    my @parent_names = $meta->superclasses;
 
     # XXX: don't feel like messing with multiple inheritance here... what would
     # that even do?
-    return unless @parents == 1;
-    my ($parent) = @parents;
-    my $parent_meta = Class::MOP::Class->initialize($parent);
+    return unless @parent_names == 1;
+    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->meta->get_method($_) } $meta->meta->get_method_list) {
+    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->meta->can('does_role')
-             && $meta->meta->does_role($method->original_package_name);
+        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;
     }
@@ -410,12 +436,8 @@ sub _is_role_only_subclass {
     # FIXME - this really isn't right. Just because an attribute is
     # defined in a role doesn't mean it isn't _also_ defined in the
     # subclass.
-    for my $attr (map { $meta->meta->get_attribute($_) } $meta->meta->get_attribute_list) {
-        next if any { $_->has_attribute($attr->name) }
-                map { $_->meta->can('calculate_all_roles')
-                    ? $_->meta->calculate_all_roles
-                    : () }
-                $meta->linearized_isa;
+    for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
+        next if any { $_->has_attribute($attr->name) } @roles;
 
         return 0;
     }
@@ -427,64 +449,84 @@ sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
     my $self = shift;
     my ($super_meta) = @_;
 
-    my $common_base = $self->_find_common_base($self, $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);
-    return unless $common_base->isa('Moose::Meta::Class');
-
-    my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
-    my @ancestors = $self->_get_ancestors_until($self, $common_base);
-    # we're only dealing with roles here
-    return unless all { $self->_is_role_only_subclass($_) }
-                      (@superclass_ancestors, @ancestors);
+    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 {
     my $self = shift;
-    my ($metaclass_type, $super_metaclass) = @_;
+    my ($metaclass_type, $super_meta) = @_;
 
-    my $meta = $self->$metaclass_type;
-    return unless $super_metaclass->can($metaclass_type);
-    my $super_meta = $super_metaclass->$metaclass_type;
+    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;
 
-    my $common_base = $self->_find_common_base($meta, $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);
-    return unless $common_base->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 @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
-    my @ancestors = $self->_get_ancestors_until($meta, $common_base);
-    # we're only dealing with roles here
-    return unless all { $self->_is_role_only_subclass($_) }
-                      (@superclass_ancestors, @ancestors);
+    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 ($meta, $super_meta) = @_;
-    my @super_roles = $super_meta->meta->calculate_all_roles;
-    my @roles = $meta->meta->calculate_all_roles;
+    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 (@super_roles) {
-        push @differences, $role unless any { $_->name eq $role->name } @roles;
+    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 ($meta, $super_meta, $base_class) = @_;
+    my ($class_meta_name, $super_meta_name) = @_;
 
-    my @role_differences = $self->_role_differences($meta, $super_meta);
-    return $self->meta->create_anon_class(
-        superclasses => [$super_meta],
+    my @role_differences = $self->_role_differences(
+        $class_meta_name, $super_meta_name,
+    );
+    return Moose::Meta::Class->create_anon_class(
+        superclasses => [$super_meta_name],
         roles        => \@role_differences,
         cache        => 1,
     );
@@ -518,8 +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 $subclass = $self->_reconcile_roles_for_metaclass($self, $super_meta, 'Moose::Meta::Class');
-        $subclass->meta->rebless_instace($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 );
     }
 }
 
@@ -530,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;
-        my $subclass = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type, $metaclasses{$metaclass_type});
-        $self->$metaclass_type($subclass->name);
+        ($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);
+        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 ) = @_;
 
@@ -715,6 +789,11 @@ This adds an C<augment> method modifier to the package.
 This will return a unique array of C<Moose::Meta::Role> instances
 which are attached to this class.
 
+=item B<< $metaclass->calculate_all_roles_with_inheritance >>
+
+This will return a unique array of C<Moose::Meta::Role> instances
+which are attached to this class, and each of this class's ancestors.
+
 =item B<< $metaclass->add_role($role) >>
 
 This takes a L<Moose::Meta::Role> object, and adds it to the class's