use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
use Try::Tiny;
+use List::MoreUtils 'all';
our $VERSION = '1.01';
$VERSION = eval $VERSION;
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
+## Metaclass compatibility
+{
+ my %base_metaclass = (
+ attribute_metaclass => 'Class::MOP::Attribute',
+ method_metaclass => 'Class::MOP::Method',
+ wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
+ instance_metaclass => 'Class::MOP::Instance',
+ constructor_class => 'Class::MOP::Method::Constructor',
+ destructor_class => 'Class::MOP::Method::Destructor',
+ );
+
+ sub _base_metaclasses { %base_metaclass }
+}
+
sub _check_metaclass_compatibility {
my $self = shift;
- # this is always okay ...
- return if ref($self) eq 'Class::MOP::Class' &&
- $self->instance_metaclass eq 'Class::MOP::Instance';
+ if (my @superclasses = $self->superclasses) {
+ $self->_fix_metaclass_incompatibility(@superclasses);
- my @class_list = $self->linearized_isa;
- shift @class_list; # shift off $self->name
+ my %base_metaclass = $self->_base_metaclasses;
- foreach my $superclass_name (@class_list) {
- my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
+ # 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;
- # 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);
-
- ($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) . ")";
- # NOTE:
- # we also need to check that instance metaclasses
- # are compatibile in the same the class.
- ($self->instance_metaclass->isa($super_meta->instance_metaclass))
- || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
- " is not compatible with the " .
- "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
+ 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
+ );
+ }
+ }
+ }
+}
+
+sub _check_class_metaclass_compatibility {
+ my $self = shift;
+ my ( $superclass_name ) = @_;
+
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return;
+
+ # 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);
+
+ ($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) . ")";
+}
+
+sub _check_single_metaclass_compatibility {
+ my $self = shift;
+ my ( $metaclass_type, $superclass_name ) = @_;
+
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return;
+
+ # 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);
+ # 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;
+
+ 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) . ")";
+}
+
+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);
+
+ return $super_meta_type ne blessed($self)
+ && $super_meta->isa(blessed($self));
+}
+
+sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+ my $self = shift;
+ my ($metaclass_type, $super_meta) = @_;
+
+ my $specific_meta = $self->$metaclass_type;
+ return unless $super_meta->can($metaclass_type);
+ my $super_specific_meta = $super_meta->$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 $specific_meta
+ && !defined $super_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) {
+ next unless defined $self->$metaclass_type;
+ return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
+ }
+
+ return;
+}
+
+sub _can_fix_metaclass_incompatibility {
+ my $self = shift;
+ return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+}
+
+sub _fix_metaclass_incompatibility {
+ my $self = shift;
+ my @supers = @_;
+
+ my $necessary = 0;
+ for my $super (map { Class::MOP::Class->initialize($_) } @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);
+ }
+
+ 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
+ );
+ }
+ }
+}
+
+sub _fix_class_metaclass_incompatibility {
+ my $self = shift;
+ my ( $super_meta ) = @_;
+
+ if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) {
+ $super_meta->meta->rebless_instance($self);
+ }
+}
+
+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)) {
+ $self->{$metaclass_type} = $super_meta->$metaclass_type;
}
}
use warnings;
use Test::More;
+use Test::Exception;
use metaclass;
+my %metaclass_attrs = (
+ 'Instance' => 'instance_metaclass',
+ 'Attribute' => 'attribute_metaclass',
+ 'Method' => 'method_metaclass',
+ 'Method::Wrapped' => 'wrapped_method_metaclass',
+ 'Method::Constructor' => 'constructor_class',
+);
+
# meta classes
+for my $suffix ('Class', keys %metaclass_attrs) {
+ Class::MOP::Class->create(
+ "Foo::Meta::$suffix",
+ superclasses => ["Class::MOP::$suffix"]
+ );
+ Class::MOP::Class->create(
+ "Bar::Meta::$suffix",
+ superclasses => ["Class::MOP::$suffix"]
+ );
+ Class::MOP::Class->create(
+ "FooBar::Meta::$suffix",
+ superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"]
+ );
+}
+
+# checking...
+
+lives_ok {
+ Foo::Meta::Class->create('Foo')
+} '... Foo.meta => Foo::Meta::Class is compatible';
+lives_ok {
+ Bar::Meta::Class->create('Bar')
+} '... Bar.meta => Bar::Meta::Class is compatible';
+
+throws_ok {
+ Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
+} qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible';
+throws_ok {
+ Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
+} qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible';
+
+lives_ok {
+ FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
+} '... FooBar.meta => FooBar::Meta::Class is compatible';
+lives_ok {
+ FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
+} '... FooBar2.meta => FooBar::Meta::Class is compatible';
+
+Foo::Meta::Class->create(
+ 'Foo::All',
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+);
+
+throws_ok {
+ Bar::Meta::Class->create(
+ 'Foo::All::Sub::Class',
+ superclasses => ['Foo::All'],
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+ )
+} qr/compatible/, 'incompatible Class metaclass';
+for my $suffix (keys %metaclass_attrs) {
+ throws_ok {
+ Foo::Meta::Class->create(
+ "Foo::All::Sub::$suffix",
+ superclasses => ['Foo::All'],
+ (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+ $metaclass_attrs{$suffix} => "Bar::Meta::$suffix",
+ )
+ } qr/compatible/, "incompatible $suffix metaclass";
+}
+
+# fixing...
+
+lives_ok {
+ Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo'])
+} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class');
+lives_ok {
+ Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar'])
+} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class');
+
+lives_ok {
+ Class::MOP::Class->create(
+ 'Foo::All::Sub::CMOP::Class',
+ superclasses => ['Foo::All'],
+ map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+ )
+} 'metaclass fixing works with other non-default metaclasses';
+isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
+
+for my $suffix (keys %metaclass_attrs) {
+ lives_ok {
+ Foo::Meta::Class->create(
+ "Foo::All::Sub::CMOP::$suffix",
+ superclasses => ['Foo::All'],
+ (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+ $metaclass_attrs{$suffix} => "Class::MOP::$suffix",
+ )
+ } "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses";
+ for my $suffix2 (keys %metaclass_attrs) {
+ my $method = $metaclass_attrs{$suffix2};
+ isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2");
+ }
+}
+
+# initializing...
+
{
- package Foo::Meta;
- use base 'Class::MOP::Class';
+ package Foo::NoMeta;
+}
- package Bar::Meta;
- use base 'Class::MOP::Class';
+Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class');
- package FooBar::Meta;
- use base 'Foo::Meta', 'Bar::Meta';
+{
+ package Foo::NoMeta2;
}
+Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class');
+
+# unsafe fixing...
-$@ = undef;
-eval {
- package Foo;
- metaclass->import('Foo::Meta');
-};
-ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
- package Bar;
- metaclass->import('Bar::Meta');
-};
-ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
- package Foo::Foo;
- use base 'Foo';
- metaclass->import('Bar::Meta');
-};
-ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
-
-$@ = undef;
-eval {
- package Bar::Bar;
- use base 'Bar';
- metaclass->import('Foo::Meta');
-};
-ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
-
-$@ = undef;
-eval {
- package FooBar;
- use base 'Foo';
- metaclass->import('FooBar::Meta');
-};
-ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
- package FooBar2;
- use base 'Bar';
- metaclass->import('FooBar::Meta');
-};
-ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+{
+ Class::MOP::Class->create(
+ 'Foo::Unsafe',
+ attribute_metaclass => 'Foo::Meta::Attribute',
+ );
+ my $meta = Class::MOP::Class->create(
+ 'Foo::Unsafe::Sub',
+ );
+ $meta->add_attribute(foo => reader => 'foo');
+ throws_ok { $meta->superclasses('Foo::Unsafe') }
+ qr/compatibility.*pristine/,
+ "can't switch out the attribute metaclass of a class that already has attributes";
+}
done_testing;
projects / gitmo/Class-MOP.git / commitdiff