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';
use Try::Tiny;
use List::MoreUtils 'all';
-our $VERSION = '1.08';
+our $VERSION = '1.09';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
: 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;
}
}
-sub _class_metaclass_is_compatible {
- my $self = shift;
- my ( $superclass_name ) = @_;
-
- my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
- || return 1;
-
- my $super_meta_type = $super_meta->_real_ref_name;
-
- return $self->isa($super_meta_type);
-}
-
sub _check_class_metaclass_compatibility {
my $self = shift;
my ( $superclass_name ) = @_;
}
}
-sub _single_metaclass_is_compatible {
+sub _class_metaclass_is_compatible {
my $self = shift;
- my ( $metaclass_type, $superclass_name ) = @_;
+ my ( $superclass_name ) = @_;
my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
|| return 1;
- # for instance, Moose::Meta::Class has a error_class attribute, but
- # Class::MOP::Class doesn't - this shouldn't be an error
- 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 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;
+ my $super_meta_name = $super_meta->_real_ref_name;
- return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+ return $self->_is_compatible_with($super_meta_name);
}
sub _check_single_metaclass_compatibility {
}
}
-sub _can_fix_class_metaclass_incompatibility_by_subclassing {
- my $self = shift;
- my ($super_meta) = @_;
-
- my $super_meta_type = $super_meta->_real_ref_name;
-
- return $super_meta_type ne blessed($self)
- && $super_meta->isa(blessed($self));
-}
-
-sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+sub _single_metaclass_is_compatible {
my $self = shift;
- my ($metaclass_type, $super_meta) = @_;
+ my ( $metaclass_type, $superclass_name ) = @_;
- my $specific_meta = $self->$metaclass_type;
- return unless $super_meta->can($metaclass_type);
- my $super_specific_meta = $super_meta->$metaclass_type;
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return 1;
+ # for instance, Moose::Meta::Class has a error_class attribute, but
+ # Class::MOP::Class doesn't - this shouldn't be an error
+ 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 unless defined $super_specific_meta;
-
- # if metaclass is defined in superclass but not here, it's fixable
+ 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 1 unless defined $specific_meta;
-
- return $specific_meta ne $super_specific_meta
- && $super_specific_meta->isa($specific_meta);
-}
-
-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);
-
- 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;
-}
+ return 0 unless defined $self->$metaclass_type;
-sub _can_fix_metaclass_incompatibility {
- my $self = shift;
- return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+ return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
}
sub _fix_metaclass_incompatibility {
}
}
-sub _fix_class_metaclass_incompatibility {
+sub _can_fix_metaclass_incompatibility {
my $self = shift;
- my ( $super_meta ) = @_;
+ my ($super_meta) = @_;
- if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) {
- ($self->is_pristine)
- || confess "Can't fix metaclass incompatibility for "
- . $self->name
- . " because it is not pristine.";
+ return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
- my $super_meta_name = $super_meta->_real_ref_name;
-
- $super_meta_name->meta->rebless_instance($self);
+ my %base_metaclass = $self->_base_metaclasses;
+ for my $metaclass_type (keys %base_metaclass) {
+ return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
}
+
+ return;
}
-sub _fix_single_metaclass_incompatibility {
+sub _class_metaclass_can_be_made_compatible {
my $self = shift;
- 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.";
+ my ($super_meta) = @_;
- $self->{$metaclass_type} = $super_meta->$metaclass_type;
- }
+ return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
}
-sub _get_associated_single_metaclass {
+sub _single_metaclass_can_be_made_compatible {
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.";
- }
+ my ($super_meta, $metaclass_type) = @_;
- return $current_single_meta_name;
-}
+ my $specific_meta = $self->$metaclass_type;
-sub _get_compatible_single_metaclass_by_subclassing {
- my $self = shift;
- my ($single_meta_name) = @_;
+ return unless $super_meta->can($metaclass_type);
+ my $super_specific_meta = $super_meta->$metaclass_type;
- my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
+ # for instance, Moose::Meta::Class has a destructor_class, but
+ # Class::MOP::Class doesn't - this shouldn't be an error
+ return unless defined $super_specific_meta;
- if ($single_meta_name->isa($current_single_meta_name)) {
- return $single_meta_name;
- }
- elsif ($current_single_meta_name->isa($single_meta_name)) {
- return $current_single_meta_name;
- }
+ # 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;
+ return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
}
-sub _get_compatible_single_metaclass {
+sub _fix_class_metaclass_incompatibility {
my $self = shift;
- my ($single_meta_name) = @_;
+ my ( $super_meta ) = @_;
+
+ if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
+ ($self->is_pristine)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
- return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
+ my $super_meta_name = $super_meta->_real_ref_name;
+
+ $self->_make_compatible_with($super_meta_name);
+ }
}
-sub _make_metaobject_compatible {
+sub _fix_single_metaclass_incompatibility {
my $self = shift;
- my ($object) = @_;
+ my ( $metaclass_type, $super_meta ) = @_;
- my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
+ if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
+ ($self->is_pristine)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
- if (!defined($new_metaclass)) {
- confess "Can't make $object compatible with metaclass "
- . $self->_get_associated_single_metaclass(blessed($object));
+ my $new_metaclass = $self->$metaclass_type
+ ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
+ : $super_meta->$metaclass_type;
+ $self->{$metaclass_type} = $new_metaclass;
}
-
- # can't use rebless_instance here, because it might not be an actual
- # subclass in the case of, e.g. moose role reconciliation
- $new_metaclass->meta->_force_rebless_instance($object)
- if blessed($object) ne $new_metaclass;
-
- return $object;
}
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 {
$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};
projects / gitmo/Class-MOP.git / blobdiff