X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=6ef28d4e1035eca1d89c174fe0acc7faafc7fd44;hb=d5d2fbb799207b6da4a57072e42fe3617d9f91b0;hp=c5359d02549dd444b33ee9245c9b81b7d355f64f;hpb=f3d0d9438cabec472be3b8633a1a4caf015e418d;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index c5359d0..6ef28d4 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -16,7 +16,7 @@ use Devel::GlobalDestruction 'in_global_destruction';
 use Try::Tiny;
 use List::MoreUtils 'all';
 
-our $VERSION   = '1.01';
+our $VERSION   = '1.07';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -67,15 +67,10 @@ sub _construct_class_instance {
         return $meta;
     }
 
-    # NOTE:
-    # we need to deal with the possibility
-    # of class immutability here, and then
-    # get the name of the class appropriately
-    $class = (ref($class)
-                    ? ($class->is_immutable
-                        ? $class->_get_mutable_metaclass_name()
-                        : ref($class))
-                    : $class);
+    $class
+        = ref $class
+        ? $class->_real_ref_name
+        : $class;
 
     # now create the metaclass
     my $meta;
@@ -103,6 +98,16 @@ sub _construct_class_instance {
     $meta;
 }
 
+sub _real_ref_name {
+    my $self = shift;
+
+    # NOTE: we need to deal with the possibility of class immutability here,
+    # and then get the name of the class appropriately
+    return $self->is_immutable
+        ? $self->_get_mutable_metaclass_name()
+        : ref $self;
+}
+
 sub _new {
     my $class = shift;
 
@@ -185,29 +190,31 @@ sub update_package_cache_flag {
 sub _check_metaclass_compatibility {
     my $self = shift;
 
-    if (my @superclasses = $self->superclasses) {
-        $self->_fix_metaclass_incompatibility(@superclasses);
+    my @superclasses = $self->superclasses
+        or return;
 
-        my %base_metaclass = $self->_base_metaclasses;
+    $self->_fix_metaclass_incompatibility(@superclasses);
 
-        # this is always okay ...
-        return if ref($self) eq 'Class::MOP::Class'
+    my %base_metaclass = $self->_base_metaclasses;
+
+    # this is always okay ...
+    return
+        if ref($self) eq 'Class::MOP::Class'
             && all {
                 my $meta = $self->$_;
-                !defined($meta) || $meta eq $base_metaclass{$_}
-            } keys %base_metaclass;
-
-        for my $superclass (@superclasses) {
-            $self->_check_class_metaclass_compatibility($superclass);
+                !defined($meta) || $meta eq $base_metaclass{$_};
         }
+        keys %base_metaclass;
 
-        for my $metaclass_type (keys %base_metaclass) {
-            next unless defined $self->$metaclass_type;
-            for my $superclass (@superclasses) {
-                $self->_check_single_metaclass_compatibility(
-                    $metaclass_type, $superclass
-                );
-            }
+    for my $superclass (@superclasses) {
+        $self->_check_class_metaclass_compatibility($superclass);
+    }
+
+    for my $metaclass_type ( keys %base_metaclass ) {
+        next unless defined $self->$metaclass_type;
+        for my $superclass (@superclasses) {
+            $self->_check_single_metaclass_compatibility( $metaclass_type,
+                $superclass );
         }
     }
 }
@@ -219,14 +226,7 @@ sub _class_metaclass_is_compatible {
     my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
         || return 1;
 
-    # NOTE:
-    # we need to deal with the possibility
-    # of class immutability here, and then
-    # get the name of the class appropriately
-    my $super_meta_type
-        = $super_meta->is_immutable
-        ? $super_meta->_get_mutable_metaclass_name()
-        : ref($super_meta);
+    my $super_meta_type = $super_meta->_real_ref_name;
 
     return $self->isa($super_meta_type);
 }
@@ -238,14 +238,7 @@ sub _check_class_metaclass_compatibility {
     if (!$self->_class_metaclass_is_compatible($superclass_name)) {
         my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
 
-        # NOTE:
-        # we need to deal with the possibility
-        # of class immutability here, and then
-        # get the name of the class appropriately
-        my $super_meta_type
-            = $super_meta->is_immutable
-            ? $super_meta->_get_mutable_metaclass_name()
-            : ref($super_meta);
+        my $super_meta_type = $super_meta->_real_ref_name;
 
         confess "The metaclass of " . $self->name . " ("
               . (ref($self)) . ")" .  " is not compatible with "
@@ -266,8 +259,10 @@ sub _single_metaclass_is_compatible {
     return 1 unless $super_meta->can($metaclass_type);
     # for instance, Moose::Meta::Class has a destructor_class, but
     # Class::MOP::Class doesn't - this shouldn't be an error
-    return 1 if defined $self->$metaclass_type
-             && !defined $super_meta->$metaclass_type;
+    return 1 unless defined $super_meta->$metaclass_type;
+    # if metaclass is defined in superclass but not here, it's not compatible
+    # this is a really odd case
+    return 0 unless defined $self->$metaclass_type;
 
     return $self->$metaclass_type->isa($super_meta->$metaclass_type);
 }
@@ -294,14 +289,7 @@ sub _can_fix_class_metaclass_incompatibility_by_subclassing {
     my $self = shift;
     my ($super_meta) = @_;
 
-    # NOTE:
-    # we need to deal with the possibility
-    # of class immutability here, and then
-    # get the name of the class appropriately
-    my $super_meta_type
-        = $super_meta->is_immutable
-        ? $super_meta->_get_mutable_metaclass_name()
-        : ref($super_meta);
+    my $super_meta_type = $super_meta->_real_ref_name;
 
     return $super_meta_type ne blessed($self)
         && $super_meta->isa(blessed($self));
@@ -317,8 +305,11 @@ sub _can_fix_single_metaclass_incompatibility_by_subclassing {
 
     # for instance, Moose::Meta::Class has a destructor_class, but
     # Class::MOP::Class doesn't - this shouldn't be an error
-    return if defined $specific_meta
-           && !defined $super_specific_meta;
+    return unless defined $super_specific_meta;
+
+    # if metaclass is defined in superclass but not here, it's fixable
+    # this is a really odd case
+    return 1 unless defined $specific_meta;
 
     return $specific_meta ne $super_specific_meta
         && $super_specific_meta->isa($specific_meta);
@@ -332,7 +323,6 @@ sub _can_fix_metaclass_incompatibility_by_subclassing {
 
     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_subclassing($metaclass_type, $super_meta);
     }
 
@@ -346,16 +336,16 @@ sub _can_fix_metaclass_incompatibility {
 
 sub _fix_metaclass_incompatibility {
     my $self = shift;
-    my @supers = @_;
+    my @supers = map { Class::MOP::Class->initialize($_) } @_;
 
     my $necessary = 0;
-    for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+    for my $super (@supers) {
         $necessary = 1
             if $self->_can_fix_metaclass_incompatibility($super);
     }
     return unless $necessary;
 
-    for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+    for my $super (@supers) {
         if (!$self->_class_metaclass_is_compatible($super->name)) {
             $self->_fix_class_metaclass_incompatibility($super);
         }
@@ -363,8 +353,7 @@ sub _fix_metaclass_incompatibility {
 
     my %base_metaclass = $self->_base_metaclasses;
     for my $metaclass_type (keys %base_metaclass) {
-        next unless defined $self->$metaclass_type;
-        for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+        for my $super (@supers) {
             if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
                 $self->_fix_single_metaclass_incompatibility(
                     $metaclass_type, $super
@@ -384,9 +373,8 @@ sub _fix_class_metaclass_incompatibility {
                      . $self->name
                      . " because it is not pristine.";
 
-        my $super_meta_name = $super_meta->is_immutable
-                                  ? $super_meta->_get_mutable_metaclass_name
-                                  : blessed($super_meta);
+        my $super_meta_name = $super_meta->_real_ref_name;
+
         $super_meta_name->meta->rebless_instance($self);
     }
 }
@@ -774,10 +762,13 @@ sub get_all_attributes {
 
 sub superclasses {
     my $self     = shift;
-    my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
+
+    my $isa = $self->get_package_symbol(
+        { sigil => '@', type => 'ARRAY', name => 'ISA' } );
+
     if (@_) {
         my @supers = @_;
-        @{$self->get_package_symbol($var_spec)} = @supers;
+        @{$isa} = @supers;
 
         # NOTE:
         # on 5.8 and below, we need to call
@@ -796,7 +787,8 @@ sub superclasses {
         $self->_check_metaclass_compatibility();
         $self->_superclasses_updated();
     }
-    @{$self->get_package_symbol($var_spec)};
+
+    return @{$isa};
 }
 
 sub _superclasses_updated {
@@ -956,8 +948,7 @@ sub get_all_methods {
     for my $class ( reverse $self->linearized_isa ) {
         my $meta = Class::MOP::Class->initialize($class);
 
-        $methods{$_} = $meta->get_method($_)
-            for $meta->get_method_list;
+        $methods{ $_->name } = $_ for $meta->_get_local_methods;
     }
 
     return values %methods;
@@ -1170,10 +1161,7 @@ sub _immutable_metaclass {
     # metaclass roles applied (via Moose), then we want to make sure
     # that we preserve that anonymous class (see Fey::ORM for an
     # example of where this matters).
-    my $meta_name
-        = $meta->is_immutable
-        ? $meta->_get_mutable_metaclass_name
-        : ref $meta;
+    my $meta_name = $meta->_real_ref_name;
 
     my $immutable_meta = $meta_name->create(
         $class_name,
@@ -1723,7 +1711,8 @@ classes.
 =item B<< $metaclass->get_attribute_list >>
 
 This will return a list of attributes I<names> for all attributes
-defined in this class.
+defined in this class.  Note that this operates on the current class
+only, it does not traverse the inheritance hierarchy.
 
 =item B<< $metaclass->get_all_attributes >>