Add date for 1.04

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 56951c3..4b090d9 100644 (file)
--- 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.03';
 $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;
 
@@ -219,14 +224,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 +236,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 +257,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 +287,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 +303,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 +321,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,21 +334,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;
 
-    ($self->is_pristine)
-        || confess "Can't fix metaclass incompatibility for "
-                 . $self->name
-                 . " because it is not pristine.";
-
-    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);
         }
@@ -368,8 +351,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,7 +366,14 @@ sub _fix_class_metaclass_incompatibility {
     my ( $super_meta ) = @_;
 
     if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) {
-        $super_meta->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;
+
+        $super_meta_name->meta->rebless_instance($self);
     }
 }
 
@@ -393,6 +382,11 @@ sub _fix_single_metaclass_incompatibility {
     my ( $metaclass_type, $super_meta ) = @_;
 
     if ($self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta)) {
+        ($self->is_pristine)
+            || confess "Can't fix metaclass incompatibility for "
+                     . $self->name
+                     . " because it is not pristine.";
+
         $self->{$metaclass_type} = $super_meta->$metaclass_type;
     }
 }
@@ -1162,10 +1156,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,