make this a bit more extensible, for moose's benefit

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

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 6981fd8..1afc676 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -8,6 +8,7 @@ use Class::MOP::Instance;
 use Class::MOP::Method::Wrapped;
 use Class::MOP::Method::Accessor;
 use Class::MOP::Method::Constructor;
+use Class::MOP::Method::Meta;
 use Class::MOP::MiniTrait;
 
 use Carp         'confess';
@@ -124,6 +125,22 @@ sub _real_ref_name {
         : ref $self;
 }
 
+sub _meta_method_class { 'Class::MOP::Method::Meta' }
+
+sub _add_meta_method {
+    my $self = shift;
+    my $existing_method = $self->find_method_by_name('meta');
+    return if $existing_method
+           && $existing_method->isa($self->_meta_method_class);
+    $self->add_method(
+        'meta' => $self->_meta_method_class->wrap(
+            name                 => 'meta',
+            package_name         => $self->name,
+            associated_metaclass => $self,
+        )
+    );
+}
+
 sub _new {
     my $class = shift;
 
@@ -332,37 +349,31 @@ sub _fix_metaclass_incompatibility {
 
 sub _can_fix_metaclass_incompatibility {
     my $self = shift;
-    return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
-}
-
-sub _can_fix_metaclass_incompatibility_by_subclassing {
-    my $self = shift;
     my ($super_meta) = @_;
 
-    return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta);
+    return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
 
     my %base_metaclass = $self->_base_metaclasses;
     for my $metaclass_type (keys %base_metaclass) {
-        return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
+        return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
     }
 
     return;
 }
 
-sub _can_fix_class_metaclass_incompatibility_by_subclassing {
+sub _class_metaclass_can_be_made_compatible {
     my $self = shift;
     my ($super_meta) = @_;
 
-    my $super_meta_name = $super_meta->_real_ref_name;
-
-    return $self->_can_be_made_compatible_with($super_meta_name);
+    return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
 }
 
-sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+sub _single_metaclass_can_be_made_compatible {
     my $self = shift;
-    my ($metaclass_type, $super_meta) = @_;
+    my ($super_meta, $metaclass_type) = @_;
 
     my $specific_meta = $self->$metaclass_type;
+
     return unless $super_meta->can($metaclass_type);
     my $super_specific_meta = $super_meta->$metaclass_type;
 
@@ -374,14 +385,14 @@ sub _can_fix_single_metaclass_incompatibility_by_subclassing {
     # this is a really odd case
     return 1 unless defined $specific_meta;
 
-    return $specific_meta->_can_be_made_compatible_with($super_specific_meta);
+    return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
 }
 
 sub _fix_class_metaclass_incompatibility {
     my $self = shift;
     my ( $super_meta ) = @_;
 
-    if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) {
+    if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
         ($self->is_pristine)
             || confess "Can't fix metaclass incompatibility for "
                      . $self->name
@@ -397,7 +408,7 @@ sub _fix_single_metaclass_incompatibility {
     my $self = shift;
     my ( $metaclass_type, $super_meta ) = @_;
 
-    if ($self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta)) {
+    if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
         ($self->is_pristine)
             || confess "Can't fix metaclass incompatibility for "
                      . $self->name
@@ -414,17 +425,8 @@ sub _restore_metaobjects_from {
     my $self = shift;
     my ($old_meta) = @_;
 
-    for my $method ($old_meta->_get_local_methods) {
-        $self->_make_metaobject_compatible($method);
-        $self->add_method($method->name => $method);
-    }
-
-    for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
-                       map { $old_meta->get_attribute($_) }
-                           $old_meta->get_attribute_list) {
-        $self->_make_metaobject_compatible($attr);
-        $self->add_attribute($attr);
-    }
+    $self->_restore_metamethods_from($old_meta);
+    $self->_restore_metaattributes_from($old_meta);
 }
 
 sub _remove_generated_metaobjects {
@@ -435,32 +437,6 @@ sub _remove_generated_metaobjects {
     }
 }
 
-sub _make_metaobject_compatible {
-    my $self = shift;
-    my ($object) = @_;
-    my $current_single_meta_name = $self->_get_associated_single_metaclass($object);
-    $object->_make_compatible_with($current_single_meta_name);
-}
-
-sub _get_associated_single_metaclass {
-    my $self = shift;
-    my ($single_meta_name) = @_;
-
-    my $current_single_meta_name;
-    if ($single_meta_name->isa('Class::MOP::Method')) {
-        $current_single_meta_name = $self->method_metaclass;
-    }
-    elsif ($single_meta_name->isa('Class::MOP::Attribute')) {
-        $current_single_meta_name = $self->attribute_metaclass;
-    }
-    else {
-        confess "Can't make $single_meta_name compatible, it isn't an "
-              . "attribute or method metaclass.";
-    }
-
-    return $current_single_meta_name;
-}
-
 ## ANON classes
 
 {
@@ -559,18 +535,7 @@ sub create {
 
     $meta->_instantiate_module( $options{version}, $options{authority} );
 
-    # FIXME totally lame
-    $meta->add_method('meta' => sub {
-        if (Class::MOP::DEBUG_NO_META()) {
-            my ($self) = @_;
-            if (my $meta = try { $self->SUPER::meta }) {
-                return $meta if $meta->isa('Class::MOP::Class');
-            }
-            confess "'meta' method called by MOP internals"
-                if caller =~ /Class::MOP|metaclass/;
-        }
-        $class->initialize(ref($_[0]) || $_[0]);
-    }) unless $options{no_meta};
+    $meta->_add_meta_method unless $options{no_meta};
 
     $meta->superclasses(@{$options{superclasses}})
         if exists $options{superclasses};