use Try::Tiny;
use List::MoreUtils 'all';
-our $VERSION = '1.01';
+our $VERSION = '1.03';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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;
$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;
}
}
-sub _check_class_metaclass_compatibility {
+sub _class_metaclass_is_compatible {
my $self = shift;
my ( $superclass_name ) = @_;
my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
- || return;
+ || 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;
- ($self->isa($super_meta_type))
- || confess "The metaclass of " . $self->name . " ("
- . (ref($self)) . ")" . " is not compatible with "
- . "the metaclass of its superclass, "
- . $superclass_name . " (" . ($super_meta_type) . ")";
+ return $self->isa($super_meta_type);
}
-sub _check_single_metaclass_compatibility {
+sub _check_class_metaclass_compatibility {
+ my $self = shift;
+ my ( $superclass_name ) = @_;
+
+ if (!$self->_class_metaclass_is_compatible($superclass_name)) {
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+
+ my $super_meta_type = $super_meta->_real_ref_name;
+
+ confess "The metaclass of " . $self->name . " ("
+ . (ref($self)) . ")" . " is not compatible with "
+ . "the metaclass of its superclass, "
+ . $superclass_name . " (" . ($super_meta_type) . ")";
+ }
+}
+
+sub _single_metaclass_is_compatible {
my $self = shift;
my ( $metaclass_type, $superclass_name ) = @_;
my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
- || return;
+ || 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 unless $super_meta->can($metaclass_type);
+ 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 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;
- my $metaclass_type_name = $metaclass_type;
- $metaclass_type_name =~ s/_(?:meta)?class$//;
- $metaclass_type_name =~ s/_/ /g;
- ($self->$metaclass_type->isa($super_meta->$metaclass_type))
- || confess "The $metaclass_type_name metaclass for "
- . $self->name . " (" . ($self->$metaclass_type)
- . ")" . " is not compatible with the "
- . "$metaclass_type_name metaclass of its "
- . "superclass, " . $superclass_name . " ("
- . ($super_meta->$metaclass_type) . ")";
+ return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+}
+
+sub _check_single_metaclass_compatibility {
+ my $self = shift;
+ my ( $metaclass_type, $superclass_name ) = @_;
+
+ if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+ my $metaclass_type_name = $metaclass_type;
+ $metaclass_type_name =~ s/_(?:meta)?class$//;
+ $metaclass_type_name =~ s/_/ /g;
+ confess "The $metaclass_type_name metaclass for "
+ . $self->name . " (" . ($self->$metaclass_type)
+ . ")" . " is not compatible with the "
+ . "$metaclass_type_name metaclass of its "
+ . "superclass, " . $superclass_name . " ("
+ . ($super_meta->$metaclass_type) . ")";
+ }
}
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));
# 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);
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);
}
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) {
- $self->_fix_class_metaclass_incompatibility($super);
+ for my $super (@supers) {
+ if (!$self->_class_metaclass_is_compatible($super->name)) {
+ $self->_fix_class_metaclass_incompatibility($super);
+ }
}
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) {
- $self->_fix_single_metaclass_incompatibility(
- $metaclass_type, $super
- );
+ for my $super (@supers) {
+ if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
+ $self->_fix_single_metaclass_incompatibility(
+ $metaclass_type, $super
+ );
+ }
}
}
}
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);
}
}
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;
}
}
foreach my $class ( $self->linearized_isa ) {
# fetch the meta-class ...
- my $meta = $self->initialize($class);
+ my $meta = Class::MOP::Class->initialize($class);
return $meta->get_attribute($attr_name)
if $meta->has_attribute($attr_name);
}
sub get_all_attributes {
my $self = shift;
- my %attrs = map { %{ $self->initialize($_)->_attribute_map } }
+ my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
reverse $self->linearized_isa;
return values %attrs;
}
return (
$name,
map {
- $self->initialize($_)->class_precedence_list()
+ Class::MOP::Class->initialize($_)->class_precedence_list()
} $self->superclasses()
);
}
(defined $method_name && length $method_name)
|| confess "You must define a method name to find";
foreach my $class ($self->linearized_isa) {
- my $method = $self->initialize($class)->get_method($method_name);
+ my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
return $method if defined $method;
}
return;
my %methods;
for my $class ( reverse $self->linearized_isa ) {
- my $meta = $self->initialize($class);
+ my $meta = Class::MOP::Class->initialize($class);
$methods{$_} = $meta->get_method($_)
for $meta->get_method_list;
sub get_all_method_names {
my $self = shift;
my %uniq;
- return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa;
+ return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
}
sub find_all_methods_by_name {
my @methods;
foreach my $class ($self->linearized_isa) {
# fetch the meta-class ...
- my $meta = $self->initialize($class);
+ my $meta = Class::MOP::Class->initialize($class);
push @methods => {
name => $method_name,
class => $class,
my @cpl = $self->linearized_isa;
shift @cpl; # discard ourselves
foreach my $class (@cpl) {
- my $method = $self->initialize($class)->get_method($method_name);
+ my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
return $method if defined $method;
}
return;
# 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,